873a153 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge branch 'develop' into ts-route-maybe

873a153Elliot Cameron7 years ago

.github/pull_request_template.mdnew file+8

compare with master

unifiedsplit

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

1+[Provide a clear overview of your changes.]

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

CONTRIBUTING.md+5

@@ -5,6 +5,7 @@ Contributions and issue reports are encouraged and appreciated!

5- [Opening Issues](#opening-issues)

6- [Submitting Changes](#submitting-changes)

7 - [Guidelines for Commit Messages](#guidelines-for-commit-messages)

8+ - [Guidelines for Pull Requests](#guidelines-for-pull-requests)

8 - [Code Quality](#code-quality)

9 - [Code Quality](#code-quality)

9 - [Documentation](#documentation)

10 - [Documentation](#documentation)

@@ -34,6 +35,10 @@ Commits that update a dependency should include some information about why the d

34#### Body

35#### Body

35For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.

36For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.

38+### Guidelines for Pull Requests

39+

40+Wherever possible, pull requests should add a single feature or fix a single bug. Pull requests should not bundle several unrelated changes.

41+

37### Code Quality

42### Code Quality

39#### Warnings

44#### Warnings

ChangeLog.md+36−1

@@ -3,13 +3,48 @@

3This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release.

5## Unreleased

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

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

10+

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

12+* 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))

13+* 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))

14+* 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))

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

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

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

18+* 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))

19+

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

21+

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

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

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

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

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

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

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

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

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

31+* Enable HTTPS in `ob run`.

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

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

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

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

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

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

38+

39+## v0.2.0.0 - 2019-8-17

40+

6* Configs become ByteStrings.

41* Configs become ByteStrings.

7* FrontendConfigsT has been changed into ConfigsT and configs are made available via getConfig/getConfigs

42* FrontendConfigsT has been changed into ConfigsT and configs are made available via getConfig/getConfigs

8 * The frontend will still only have access to configs that are placed in config/frontend and config/common, while the backend has access to the entire contents of the config directory via `Obelisk.ExecutableConfig.Lookup.getConfigs`.

43 * The frontend will still only have access to configs that are placed in config/frontend and config/common, while the backend has access to the entire contents of the config directory via `Obelisk.ExecutableConfig.Lookup.getConfigs`.

9* The backend no longer runs in BackendConfigsT.

44* The backend no longer runs in BackendConfigsT.

10* Add tabulation package. See Data.Tabulation for details.

45* Add tabulation package. See Data.Tabulation for details.

11* Add encoders for `DMap`, `HasFields` (cf. Data.Tabulation), and JSON.

46* Add encoders for `DMap`, `HasFields` (cf. Data.Tabulation), and JSON.

12−* Add `?/`, a convenience function for constructing routes nested in `Maybe`.

47+* Use IP address for nginx proxy pass instead of localhost

14## v0.1.1.0 - 2019-05-17

49## v0.1.1.0 - 2019-05-17

FAQ.md+2−2

@@ -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 -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

@@ -109,7 +109,7 @@ It is defined in `lib/run/src/Obelisk/Run.hs`:

109 * or to `serveDefaultObeliskApp` (`lib/backend/src/Obelisk/Backend.hs`) to

110 serve static assets.

111* Starts `runWidget`

112− which itself runs

112+ which itself runs

113 [runSettingsSocket](https://hackage.haskell.org/package/warp-3.2.26/docs/Network-Wai-Handler-Warp.html#v:runSettingsSocket)

114 (the *“TCP listen loop”*):

115 * it binds to TCP socket, and

README.md+60−15

@@ -5,7 +5,9 @@ Obelisk provides an easy way to develop and deploy your [Reflex](https://github.

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

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

7 - [Hoogle](#hoogle)

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

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

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

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

9- [Deploying](#deploying)

11- [Deploying](#deploying)

10 - [Locally](#locally)

12 - [Locally](#locally)

11 - [EC2](#ec2)

13 - [EC2](#ec2)

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

211. Set up nix caches

231. Set up nix caches

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

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

23 ```

25 ```

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

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

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

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

26 ```

28 ```

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

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

28 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)):

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)):

29 ```

31 ```

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

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

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

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

34+ binary-caches-parallel-connections = 40

32 ```

35 ```

33 * 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 * 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)

34 ```

37 ```

@@ -59,6 +62,28 @@ Or to launch ghcid for `lib/command` project:

59nix-shell -A obeliskEnvs.obelisk-command --run "cd lib/command && ghcid -c 'cabal new-repl'"

62nix-shell -A obeliskEnvs.obelisk-command --run "cd lib/command && ghcid -c 'cabal new-repl'"

60```

63```

65+To re-install `ob` from source do

66+```

67+nix-env -f /path/to/obelisk -iA command

68+```

69+

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

71+

72+```shell

73+ob thunk unpack ./.obelisk/impl

74+cd ./.obelisk/impl

75+# apply your changes

76+```

77+

78+If you want to commit your changes, first push them to your fork of obelisk and then

79+

80+```shell

81+cd /your/project/root

82+ob thunk pack .obelisk/impl

83+git add .obelisk/impl

84+git commit -m "Bump obelisk"

85+```

86+

62### Accessing private repositories

87### Accessing private repositories

64To allow the Nix builder to access private git repositories, you must be set up

89To allow the Nix builder to access private git repositories, you must be set up

@@ -82,7 +107,8 @@ Obelisk leverages ghcid to provide a live-reloading server that handles both fro

82ob run

107ob run

83```

108```

109

85−Now go to http://localhost:8000 (or the address/port specified in `config/common/route`) to access your app.

110+Now, with an appropriate browser, go to http://localhost:8000 (or the address/port specified in `config/common/route`) to access your app.

111+Firefox will not be able to properly run the development website due to [issue 460](https://github.com/obsidiansystems/obelisk/issues/460). Fortunately, this problem does not occur on a fully built website.

112

87Every 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.

113Every 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.

114

@@ -92,16 +118,20 @@ To enter a nix-shell from which you can run the hoogle command-line client or a

118

93`nix-shell -A shells.ghc --arg withHoogle true`

119`nix-shell -A shells.ghc --arg withHoogle true`

120

121+### Adding packages

122+

123+In 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.

124+

95### Adding package overrides

125### Adding package overrides

126

97−To add a version override to any Haskell package, or to add a Haskell package that doesn't exist in the nixpkgs used by Obelisk, use the `overrides` attribute in your project's `default.nix`. For example, to use a specific version of the `aeson` package, your `default.nix` will look like:

127+To add a version override to any Haskell package, or to add a Haskell package that doesn't exist in the nixpkgs used by Obelisk, use the `overrides` attribute in your project's `default.nix`. For example, to use a specific version of the `aeson` package fetched from GitHub and a specific version of the `waargonaut` package fetched from Hackage, your `default.nix` will look like:

128

99```nix

129```nix

100# ...

130# ...

101project ./. ({ pkgs, ... }: {

131project ./. ({ pkgs, ... }: {

102# ...

132# ...

103 overrides = self: super: let

133 overrides = self: super: let

104− aeson = pkgs.fetchFromGitHub {

134+ aesonSrc = pkgs.fetchFromGitHub {

105 owner = "obsidiansystems";

135 owner = "obsidiansystems";

106 repo = "aeson-gadt-th";

136 repo = "aeson-gadt-th";

107 rev = "ed573c2cccf54d72aa6279026752a3fecf9c1383";

137 rev = "ed573c2cccf54d72aa6279026752a3fecf9c1383";

@@ -109,13 +139,24 @@ project ./. ({ pkgs, ... }: {

109 };

139 };

110 in

140 in

111 {

141 {

112− aeson = self.callCabal2nix "aeson" aeson {};

142+ aeson = self.callCabal2nix "aeson" aesonSrc {};

143+ waargonaut = self.callHackageDirect {

144+ pkg = "waargonaut";

145+ ver = "0.8.0.1";

146+ sha256 = "1zv28np3k3hg378vqm89v802xr0g8cwk7gy3mr77xrzy5jbgpa39";

147+ } {};

113 };

148 };

114# ...

149# ...

115```

150```

116

151

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

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

118

153

154+### Running over https

155+

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

157+

158+Since 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.

159+

119## Deploying

160## Deploying

120

161

121### Locally

162### Locally

@@ -123,14 +164,16 @@ For further information see [the Haskell section](https://nixos.org/nixpkgs/manu

123Build everything:

164Build everything:

124

165

125```

166```

126−nix-build -A exe -o result-exe

167+nix-build -A exe --no-out-link

127```

168```

128

169

129−Run the server:

170+Copy the result to a new directory, add configuration, and run!

130

171

131```

172```

132−cd result-exe

173+mkdir test-app

174+ln -s $(nix-build -A exe --no-out-link)/* test-app/

175+cp -r config test-app

133−./backend

176+(cd test-app && ./backend)

134```

177```

135

178

136### EC2

179### EC2

@@ -162,9 +205,11 @@ ob deploy init \

162 ~/code/myapp-deploy

205 ~/code/myapp-deploy

163```

206```

164

207

165−NOTE: HTTPS is enabled by default; to disable https, pass `--disable-https` to the `ob deploy init` command above.

208+HTTPS is enabled by default; to disable https, pass `--disable-https` to the `ob deploy init` command above.

209+

210+This step will also require that you manually verify the authenticity of the host `$SERVER`. Obelisk will save the fingerprint in a deployment-specific configuration. **Obelisk deployments do *not* rely on the `known_hosts` of your local machine.** This is because, in the event that you need to switch from one deploy machine / bastion host to another, you want to be absolutely sure that you're still connecting to the machines you think you are, even if that deploy machine / bastion host has never connected to them before. Obelisk explicitly avoids a workflow that encourages people to accept host keys without checking them, since that could result in leaking production secrets to anyone who manages to MITM you, e.g. via DNS spoofing or cache poisoning. (Note that an active attack is a circumstance where you may need to quickly switch bastion hosts, e.g. because the attacker has taken one down or you have taken it down in case it was compromised. In this circumstance you might need to deploy to production to fix an exploit or rotate keys, etc.) When you run `ob deploy` later it will rely on the saved verification in this step.

166

211

167−Then go to that created deployment configuration directory, and initiate the deployment:

212+Next, go to the deployment directory that you just initialized and deploy!

168

213

169```

214```

170cd ~/code/myapp-deploy

215cd ~/code/myapp-deploy

@@ -290,9 +335,9 @@ This command will accomplish the following:

2901. Build a Signed Android apk for your application

3351. Build a Signed Android apk for your application

2911. Deploy the Signed apk to your connected Android device

3361. Deploy the Signed apk to your connected Android device

292

337

293−In the event that you change your key or keystore password, you will have to update your credentials within the JSON object found in `android_keytool_config.json`

338+In the event that you change your key or keystore password, you will have to update your credentials within the JSON object found in `android_keytool_config.json`.

294

339

295−Additional documentation on java key stores can be found [here] (https://docs.oracle.com/javase/8/docs/technotes/tools/unix/keytool.html)

340+Additional documentation on Java key stores can be found [here](https://docs.oracle.com/javase/8/docs/technotes/tools/unix/keytool.html).

296

341

297This should copy over and install the application on your device (if you see a "*signatures do not match*" error, simply uninstall the previous app from the device before retrying the deploy). The name of the installed application will be what you have specified for `android.displayName` in the `default.nix`.

342This should copy over and install the application on your device (if you see a "*signatures do not match*" error, simply uninstall the previous app from the device before retrying the deploy). The name of the installed application will be what you have specified for `android.displayName` in the `default.nix`.

298

343

all-builds.nixnew file+117

@@ -0,0 +1,117 @@

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+ concatDepends = let

42+ extractDeps = x: (x.override {

43+ mkDerivation = drv: {

44+ out = builtins.concatLists [

45+ (drv.buildDepends or [])

46+ (drv.libraryHaskellDepends or [])

47+ (drv.executableHaskellDepends or [])

48+ ];

49+ };

50+ }).out;

51+ in pkgAttrs: builtins.concatLists (map extractDeps (builtins.attrValues pkgAttrs));

52+

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

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

55+ perProfiling = profiling: let

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

57+ ghc = pnameToAttrs

58+ obelisk.haskellPackageSets.ghc

59+ obeliskPackagesBackend;

60+ ghcjs = pnameToAttrs

61+ obelisk.haskellPackageSets.ghcjs

62+ obeliskPackagesCommon;

63+ cachePackages = builtins.concatLists [

64+ (builtins.attrValues ghc)

65+ (lib.optionals (!profiling) (builtins.attrValues ghcjs))

66+ (concatDepends ghc)

67+ (lib.optionals (!profiling) (concatDepends ghcjs))

68+ (lib.optional reflex-platform.androidSupport androidSkeleton)

69+ (lib.optional reflex-platform.iosSupport iosSkeleton)

70+ (lib.optionals (!profiling) [

71+ command

72+ serverSkeletonExe

73+ serverSkeletonShell

74+ ])

75+ ];

76+ command = obelisk.command;

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

78+ serverSkeletonExe = skeleton.exe;

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

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

81+ touch "$out"

82+ echo "return" >> "$out"

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

84+ '';

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

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

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

88+ in {

89+ inherit

90+ ghc

91+ ;

92+ cache = reflex-platform.pinBuildInputs "obelisk-${system}-${nameSuffix}" cachePackages;

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

94+ inherit

95+ command

96+ ghcjs

97+ serverSkeletonExe

98+ serverSkeletonShell

99+ ;

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

101+ inherit androidSkeleton;

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

103+ inherit iosSkeleton;

104+ };

105+ profiled = perProfiling true;

106+ unprofiled = perProfiling false;

107+ cachePackages = map (p: p.cache) [ profiled unprofiled ];

108+ in {

109+ inherit profiled unprofiled;

110+ cache = reflex-platform.pinBuildInputs "obelisk-${system}" cachePackages;

111+ });

112+

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

114+ "obelisk-everywhere"

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

116+

117+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": false' ~/code/myapp/git.json""")

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

144+ '';

145+ }) {}

default.nix+54−52

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

2, profiling ? false

3, iosSdkVersion ? "10.2"

4, config ? {}

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

5}:

6}:

6let

7let

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

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

@@ -16,7 +17,7 @@ let

16 openssh

17 openssh

17 ];

18 ];

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

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

20 inherit iosSdkVersion config;

21 inherit iosSdkVersion config;

21 system = sys;

22 system = sys;

22 enableLibraryProfiling = profiling;

23 enableLibraryProfiling = profiling;

@@ -32,13 +33,12 @@ let

32 # Fix misc upstream packages

33 # Fix misc upstream packages

33 (self: super: let

34 (self: super: let

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

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

36+ haskellLib = pkgs.haskell.lib;

35 in {

37 in {

36− hnix = pkgs.haskell.lib.dontCheck (self.callCabal2nix "hnix" (pkgs.fetchFromGitHub {

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

37− owner = "haskell-nix";

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

38− repo = "hnix";

40+

39− rev = "42afdc21da5d9e076eab57eaa42bfdde938192b8";

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

40− sha256 = "0psw384dx9bw2dp93xrzw8rd9amvcwgzn64jzzwby7sfspj6k349";

41− }) {});

42 })

44 pkgs.obeliskExecutableConfig.haskellOverlay

@@ -46,18 +46,33 @@ let

46 # Add obelisk packages

47 (self: super: let

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

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

49 in {

50 in {

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

52+

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

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

52− obelisk-asset-manifest = self.callCabal2nix "obelisk-asset-manifest" (hackGet ./lib/asset + "/manifest") {};

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

53− obelisk-asset-serve-snap = self.callCabal2nix "obelisk-asset-serve-snap" (hackGet ./lib/asset + "/serve-snap") {};

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

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

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

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

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

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

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

60+ librarySystemDepends = [

61+ pkgs.nix

62+ (haskellLib.justStaticExecutables self.ghcid)

63+ ];

64+ };

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

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

58− 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+ );

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

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

60− 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+ ];

75+ };

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

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

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

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

63 })

78 })

@@ -65,31 +80,11 @@ let

65 (self: super: let

80 (self: super: let

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

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

67 haskellLib = pkgs.haskell.lib;

82 haskellLib = pkgs.haskell.lib;

68− #TODO: Upstream

69− # Modify a Haskell package to add completion scripts for the given

70− # executable produced by it. These completion scripts will be picked up

71− # automatically if the resulting derivation is installed, e.g. by

72− # `nix-env -i`.

73− addOptparseApplicativeCompletionScripts = exeName: pkg: haskellLib.overrideCabal pkg (drv: {

74− postInstall = (drv.postInstall or "") + ''

75− BASH_COMP_DIR="$out/share/bash-completion/completions"

76− mkdir -p "$BASH_COMP_DIR"

77− "$out/bin/${exeName}" --bash-completion-script "$out/bin/${exeName}" >"$BASH_COMP_DIR/ob"

78−

79− ZSH_COMP_DIR="$out/share/zsh/vendor-completions"

80− mkdir -p "$ZSH_COMP_DIR"

81− "$out/bin/${exeName}" --zsh-completion-script "$out/bin/${exeName}" >"$ZSH_COMP_DIR/_ob"

82−

83− FISH_COMP_DIR="$out/share/fish/vendor_completions.d"

84− mkdir -p "$FISH_COMP_DIR"

85− "$out/bin/${exeName}" --fish-completion-script "$out/bin/${exeName}" >"$FISH_COMP_DIR/ob.fish"

86− '';

87− });

88 in {

83 in {

89 # Dynamic linking with split objects dramatically increases startup time (about

84 # Dynamic linking with split objects dramatically increases startup time (about

90 # 0.5 seconds on a decent machine with SSD), so we do `justStaticExecutables`.

85 # 0.5 seconds on a decent machine with SSD), so we do `justStaticExecutables`.

91 obelisk-command = haskellLib.overrideCabal

86 obelisk-command = haskellLib.overrideCabal

92− (addOptparseApplicativeCompletionScripts "ob"

87+ (haskellLib.generateOptparseApplicativeCompletion "ob"

93 (haskellLib.justStaticExecutables super.obelisk-command))

88 (haskellLib.justStaticExecutables super.obelisk-command))

94 (drv: {

89 (drv: {

95 buildTools = (drv.buildTools or []) ++ [ pkgs.buildPackages.makeWrapper ];

90 buildTools = (drv.buildTools or []) ++ [ pkgs.buildPackages.makeWrapper ];

@@ -126,19 +121,19 @@ in rec {

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

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

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

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

128 obelisk = ghcObelisk;

123 obelisk = ghcObelisk;

129− obeliskEnvs = ghcObeliskEnvs;

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

130 command = ghcObelisk.obelisk-command;

125 command = ghcObelisk.obelisk-command;

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

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

132

127

133 selftest = pkgs.writeScript "selftest" ''

128 selftest = pkgs.writeScript "selftest" ''

134 #!/usr/bin/env bash

129 #!/usr/bin/env bash

135 set -euo pipefail

130 set -euo pipefail

136

131

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

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

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

133+ export OBELISK_IMPL="$(mktemp -d)"

134+ git clone file://${pathGit} $OBELISK_IMPL

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

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

140 '';

136 '';

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

142 skeleton = pkgs.runCommand "skeleton" {

137 skeleton = pkgs.runCommand "skeleton" {

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

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

144 } ''

139 } ''

@@ -157,12 +152,17 @@ in rec {

157 obelisk-asset-manifest-generate "$src" "$haskellManifest" ${packageName} ${moduleName} "$symlinked"

152 obelisk-asset-manifest-generate "$src" "$haskellManifest" ${packageName} ${moduleName} "$symlinked"

158 '';

153 '';

159

154

160− compressedJs = frontend: optimizationLevel: pkgs.runCommand "compressedJs" { buildInputs = [ pkgs.closurecompiler ]; } ''

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

161 mkdir $out

156 mkdir $out

162 cd $out

157 cd $out

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

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

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

160+ ${if optimizationLevel == null then ''

161+ ln -s all.unminified.js all.js

162+ '' else ''

164− closure-compiler --externs "${reflex-platform.ghcjsExternsJs}" -O ${optimizationLevel} --jscomp_warning=checkVars --create_source_map="all.js.map" --source_map_format=V3 --js_output_file="all.js" all.unminified.js

163+ ${pkgs.closurecompiler}/bin/closure-compiler --externs "${reflex-platform.ghcjsExternsJs}" -O ${optimizationLevel} --jscomp_warning=checkVars --create_source_map="all.js.map" --source_map_format=V3 --js_output_file="all.js" all.unminified.js

165− echo "//# sourceMappingURL=all.js.map" >> all.js

164+ echo "//# sourceMappingURL=all.js.map" >> all.js

165+ ''}

166 '';

167

168 serverModules = {

@@ -198,7 +198,7 @@ in rec {

198 enableACME = enableHttps;

199 forceSSL = enableHttps;

200 locations.${baseUrl} = {

201− proxyPass = "http://localhost:" + toString internalPort;

201+ proxyPass = "http://127.0.0.1:" + toString internalPort;

202 proxyWebsockets = true;

203 };

204 };

@@ -207,10 +207,11 @@ in rec {

207 wantedBy = [ "multi-user.target" ];

208 after = [ "network.target" ];

209 restartIfChanged = true;

210+ path = [ pkgs.gnutar ];

210 script = ''

211 script = ''

211 ln -sft . '${exe}'/*

212 ln -sft . '${exe}'/*

212 mkdir -p log

213 mkdir -p log

213− exec ./backend ${backendArgs} >>backend.out 2>>backend.err </dev/null

214+ exec ./backend ${backendArgs} </dev/null

214 '';

215 '';

215 serviceConfig = {

216 serviceConfig = {

216 User = user;

217 User = user;

@@ -237,7 +238,7 @@ in rec {

237 pkgs.runCommand "serverExe" {} ''

238 pkgs.runCommand "serverExe" {} ''

238 mkdir $out

239 mkdir $out

239 set -eux

240 set -eux

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

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

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

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

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

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

243 echo ${version} > $out/version

244 echo ${version} > $out/version

@@ -268,7 +269,7 @@ in rec {

268 , tools ? _: []

269 , tools ? _: []

269 , shellToolOverrides ? _: _: {}

270 , shellToolOverrides ? _: _: {}

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

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

271− , __closureCompilerOptimizationLevel ? "ADVANCED"

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

272 }:

273 }:

273 let frontendName = "frontend";

274 let frontendName = "frontend";

274 backendName = "backend";

275 backendName = "backend";

@@ -335,18 +336,19 @@ in rec {

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

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

336 };

337 };

337 in mkProject (projectDefinition args));

338 in mkProject (projectDefinition args));

339+ mainProjectOut = projectOut system;

338− serverOn = sys: version: serverExe

340+ serverOn = projectInst: version: serverExe

339− (projectOut sys).ghc.backend

341+ projectInst.ghc.backend

340− (projectOut system).ghcjs.frontend

342+ mainProjectOut.ghcjs.frontend

341− (projectOut sys).passthru.staticFiles

343+ projectInst.passthru.staticFiles

342− (projectOut sys).passthru.__closureCompilerOptimizationLevel

344+ projectInst.passthru.__closureCompilerOptimizationLevel

343 version;

345 version;

344− linuxExe = serverOn "x86_64-linux";

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

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

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

346− in projectOut system // {

348+ in mainProjectOut // {

347 linuxExeConfigurable = linuxExe;

349 linuxExeConfigurable = linuxExe;

348 linuxExe = linuxExe dummyVersion;

350 linuxExe = linuxExe dummyVersion;

349− exe = serverOn system dummyVersion;

351+ exe = serverOn mainProjectOut dummyVersion;

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

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

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

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

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

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

dep/.gitignore+1

@@ -1,4 +1,5 @@

2+!*/

2!.gitignore

3!.gitignore

3!*/*.json

4!*/*.json

4!*/default.nix

5!*/default.nix

dep/ghcid/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/ghcid/github.jsonnew file+7

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

1+{

2+ "owner": "ndmitchell",

3+ "repo": "ghcid",

4+ "branch": "master",

5+ "rev": "f572318f32b1617f6054248e5888af68222f8e50",

6+ "sha256": "1icg3r70lg2kmd9gdc024ih1n9nrja98yav74z9nvykqygvv5w0n"

7+}

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/github.json+3−3

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

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "cg-bump-reflex-dom",

4+ "branch": "develop",

5− "rev": "7ecb4c255bb053a7a4796ffd6331cdbe210de91c",

5+ "rev": "90351bdb2c99d416ea95fd5b8b474e8f9fab2942",

6− "sha256": "1mngxa24cfpvxxq4hgh77nw36vny4abl5wi2xmlwpkk25wzm0h0x"

6+ "sha256": "0bbzz4ckdx0ilhhpd3drfbsc0zdb2rnhw2m3nls9villbs3lz3lh"

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/Serve/Snap.hs+7−6

@@ -19,6 +19,7 @@ import Control.Applicative ((<|>))

19import Control.Exception (handleJust, try, throwIO)

20import Control.Monad (forM, liftM)

21import Control.Monad.IO.Class (liftIO)

22+import Control.Monad.Fail (MonadFail)

22import Data.Attoparsec.ByteString (parseOnly, endOfInput)

23import Data.Attoparsec.ByteString (parseOnly, endOfInput)

23import Data.ByteString (ByteString)

24import Data.ByteString (ByteString)

24import qualified Data.ByteString as BS

25import qualified Data.ByteString as BS

@@ -38,7 +39,7 @@ import System.Posix (getFileStatus, fileSize)

38-- current version of the asset

39-- current version of the asset

39-- (e.g. @0rx5yvkkgkig2pcqf4ngi1l7vh89qqajdzc6aiayaibyhvj0d853-test.png@). Hashed

40-- (e.g. @0rx5yvkkgkig2pcqf4ngi1l7vh89qqajdzc6aiayaibyhvj0d853-test.png@). Hashed

40-- asset names will be sent with permanent caching headers.

41-- asset names will be sent with permanent caching headers.

41−serveAssets :: MonadSnap m => FilePath -> FilePath -> m ()

42+serveAssets :: (MonadSnap m, MonadFail m) => FilePath -> FilePath -> m ()

42serveAssets = serveAssets' True

43serveAssets = serveAssets' True

44-- | Serve static assets from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

45-- | Serve static assets from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

@@ -47,15 +48,15 @@ serveAssets = serveAssets' True

47-- browser for the logical asset name (e.g. @test.png@) but instead the current

48-- browser for the logical asset name (e.g. @test.png@) but instead the current

48-- version of the asset with to point the browser at the unique filename for the

49-- version of the asset with to point the browser at the unique filename for the

49-- current version of the asset.

50-- current version of the asset.

50−serveAssetsInPlace :: MonadSnap m => FilePath -> FilePath -> m ()

51+serveAssetsInPlace :: (MonadSnap m, MonadFail m) => FilePath -> FilePath -> m ()

51serveAssetsInPlace = serveAssets' False

52serveAssetsInPlace = serveAssets' False

53-- | Like 'serveAssets', but only serves a single specified asset

54-- | Like 'serveAssets', but only serves a single specified asset

54−serveAsset :: MonadSnap m => FilePath -> FilePath -> FilePath -> m ()

55+serveAsset :: (MonadSnap m, MonadFail m) => FilePath -> FilePath -> FilePath -> m ()

55serveAsset = serveAsset' True

56serveAsset = serveAsset' True

57-- | Like 'serveAssetsInPlace', but only serves a single specified asset

58-- | Like 'serveAssetsInPlace', but only serves a single specified asset

58−serveAssetInPlace :: MonadSnap m => FilePath -> FilePath -> FilePath -> m ()

59+serveAssetInPlace :: (MonadSnap m, MonadFail m) => FilePath -> FilePath -> FilePath -> m ()

59serveAssetInPlace = serveAsset' False

60serveAssetInPlace = serveAsset' False

61-- | Serve static assets from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

62-- | Serve static assets from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

@@ -63,13 +64,13 @@ serveAssetInPlace = serveAsset' False

63-- For assets generated from @assets.nix@, the @Bool@ argument @doRedirect@ controls whether redirects will be sent to the browser if a request is made for

64-- For assets generated from @assets.nix@, the @Bool@ argument @doRedirect@ controls whether redirects will be sent to the browser if a request is made for

64-- an unhashed asset name, e.g. @test.png@. For @True@, a redirect will be sent, yielding more round trips to the server but better caching behavior if the

65-- an unhashed asset name, e.g. @test.png@. For @True@, a redirect will be sent, yielding more round trips to the server but better caching behavior if the

65-- asset doesn't change often. Conversely for @False@, the asset will be served "in place" but made uncacheable.

66-- asset doesn't change often. Conversely for @False@, the asset will be served "in place" but made uncacheable.

66−serveAssets' :: MonadSnap m => Bool -> FilePath -> FilePath -> m ()

67+serveAssets' :: (MonadSnap m, MonadFail m) => Bool -> FilePath -> FilePath -> m ()

67serveAssets' doRedirect base fallback = do

68serveAssets' doRedirect base fallback = do

68 pRaw <- getSafePath

69 pRaw <- getSafePath

69 serveAsset' doRedirect base fallback $ if "/" `isSuffixOf` pRaw || pRaw == "" then pRaw <> "index.html" else pRaw

70 serveAsset' doRedirect base fallback $ if "/" `isSuffixOf` pRaw || pRaw == "" then pRaw <> "index.html" else pRaw

71-- | Serve a single static asset from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

72-- | Serve a single static asset from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

72−serveAsset' :: MonadSnap m => Bool -> FilePath -> FilePath -> FilePath -> m ()

73+serveAsset' :: (MonadFail m, MonadSnap m) => Bool -> FilePath -> FilePath -> FilePath -> m ()

73serveAsset' doRedirect base fallback p = do

74serveAsset' doRedirect base fallback p = do

74 assetType <- liftIO $ try $ BS.readFile $ base </> p </> "type"

75 assetType <- liftIO $ try $ BS.readFile $ base </> p </> "type"

75 case assetType of

76 case assetType of

lib/backend/src/Obelisk/Backend.hs+14−17

@@ -26,12 +26,12 @@ import Prelude hiding (id, (.))

26import Control.Category

27import Control.Monad

28import Control.Monad.Except

29+import Control.Monad.Fail (MonadFail)

29import Control.Categorical.Bifunctor

30import Control.Categorical.Bifunctor

30import Data.ByteString (ByteString)

31import Data.ByteString (ByteString)

31import qualified Data.ByteString.Char8 as BSC8

32import qualified Data.ByteString.Char8 as BSC8

32import Data.Default (Default (..))

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

33import Data.Dependent.Sum

34import Data.Dependent.Sum

34−import Data.Functor.Sum

35import Data.Functor.Identity

36import Data.Map (Map)

37import qualified Data.Map as Map

@@ -47,12 +47,12 @@ import Obelisk.Snap.Extras (doNotCache, serveFileIfExistsAs)

47import Reflex.Dom

48import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, httpServe, modifyResponse

49 , rqPathInfo, rqQueryString, setContentType, writeBS, writeText

50− , rqCookies, Cookie(..))

50+ , rqCookies, Cookie(..) , setHeader)

51import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))

52import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)

54data Backend backendRoute frontendRoute = Backend

55− { _backend_routeEncoder :: Encoder (Either Text) Identity (R (Sum backendRoute (ObeliskRoute frontendRoute))) PageName

55+ { _backend_routeEncoder :: Encoder (Either Text) Identity (R (FullRoute backendRoute frontendRoute)) PageName

56 , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()

57 }

@@ -65,7 +65,7 @@ data GhcjsApp route = GhcjsApp

65-- | Serve a frontend, which must be the same frontend that Obelisk has built and placed in the default location

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

67serveDefaultObeliskApp

68− :: (MonadSnap m, HasCookies m)

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

69 => (R appRoute

70 -> Text)

71 -> ([Text]

@@ -114,11 +114,7 @@ getPageName :: (MonadSnap m) => m PageName

114getPageName = do

115 p <- getsRequest rqPathInfo

116 q <- getsRequest rqQueryString

117− let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)

117+ return $ byteStringsToPageName p q

118− pageNameEncoder' = bimap

119− (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)

120− (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)

121− return $ decode pageNameEncoder' (T.unpack (decodeUtf8 p), T.unpack (decodeUtf8 q))

122

118

123getRouteWith :: (MonadSnap m) => Encoder Identity parse route PageName -> m (parse route)

119getRouteWith :: (MonadSnap m) => Encoder Identity parse route PageName -> m (parse route)

124getRouteWith e = do

120getRouteWith e = do

@@ -126,7 +122,7 @@ getRouteWith e = do

126 return $ tryDecode e pageName

122 return $ tryDecode e pageName

127

123

128serveObeliskApp

124serveObeliskApp

129− :: (MonadSnap m, HasCookies m)

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

130 => (R appRoute -> Text)

126 => (R appRoute -> Text)

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

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

132 -> GhcjsApp (R appRoute)

128 -> GhcjsApp (R appRoute)

@@ -144,7 +140,7 @@ serveObeliskApp urlEnc serveStaticAsset frontendApp config = \case

144 writeText msg

140 writeText msg

145 ResourceRoute_Version :=> Identity () -> doNotCache >> serveFileIfExistsAs "text/plain" "version"

141 ResourceRoute_Version :=> Identity () -> doNotCache >> serveFileIfExistsAs "text/plain" "version"

146

142

147−serveStaticAssets :: MonadSnap m => StaticAssets -> [Text] -> m ()

143+serveStaticAssets :: (MonadSnap m, MonadFail m) => StaticAssets -> [Text] -> m ()

148serveStaticAssets assets pathSegments = serveAsset (_staticAssets_processed assets) (_staticAssets_unprocessed assets) $ T.unpack $ T.intercalate "/" pathSegments

144serveStaticAssets assets pathSegments = serveAsset (_staticAssets_processed assets) (_staticAssets_unprocessed assets) $ T.unpack $ T.intercalate "/" pathSegments

149

145

150data StaticAssets = StaticAssets

146data StaticAssets = StaticAssets

@@ -162,7 +158,7 @@ staticRenderContentType = "text/html; charset=utf-8"

162

158

163--TODO: Don't assume we're being served at "/"

159--TODO: Don't assume we're being served at "/"

164serveGhcjsApp

160serveGhcjsApp

165− :: (MonadSnap m, HasCookies m)

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

166 => (R appRouteComponent -> Text)

162 => (R appRouteComponent -> Text)

167 -> GhcjsApp (R appRouteComponent)

163 -> GhcjsApp (R appRouteComponent)

168 -> Map Text ByteString

164 -> Map Text ByteString

@@ -171,10 +167,11 @@ serveGhcjsApp

171serveGhcjsApp urlEnc app config = \case

167serveGhcjsApp urlEnc app config = \case

172 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do

168 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do

173 modifyResponse $ setContentType staticRenderContentType

169 modifyResponse $ setContentType staticRenderContentType

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

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

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

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

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

176

173

177−runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()

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

178runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

175runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

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

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

180 Right validFullEncoder -> do

177 Right validFullEncoder -> do

@@ -183,15 +180,15 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend

183 runSnapWithCommandLineArgs $ do

180 runSnapWithCommandLineArgs $ do

184 getRouteWith validFullEncoder >>= \case

181 getRouteWith validFullEncoder >>= \case

185 Identity r -> case r of

182 Identity r -> case r of

186− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

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

187− InR obeliskRoute :=> Identity a ->

184+ FullRoute_Frontend obeliskRoute :/ a ->

188 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $

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

189 obeliskRoute :/ a

186 obeliskRoute :/ a

190

187

191−mkRouteToUrl :: Encoder Identity parse (R (Sum f (ObeliskRoute r))) PageName -> R r -> Text

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

192mkRouteToUrl validFullEncoder =

189mkRouteToUrl validFullEncoder =

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

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

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

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

195

192

196renderGhcjsFrontend

193renderGhcjsFrontend

197 :: (MonadSnap m, HasCookies m)

194 :: (MonadSnap m, HasCookies m)

lib/cliapp/obelisk-cliapp.cabal+1

@@ -10,6 +10,7 @@ library

10 ansi-terminal

11 , base

12 , bytestring

13+ , containers

13 , exceptions

14 , exceptions

14 , io-streams

15 , io-streams

15 , lens

16 , lens

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

@@ -33,16 +33,23 @@ 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

45 , reconstructCommand

48 , reconstructCommand

49+ , setCwd

50+ , setDelegateCtlc

51+ , setEnvOverride

52+ , shell

46 ) where

53 ) where

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

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

lib/cliapp/src/Obelisk/CliApp/Demo.hs+2−2

@@ -4,17 +4,17 @@

4module Obelisk.CliApp.Demo where

6import Control.Concurrent (threadDelay)

7+import Control.Monad.Fail

7import Control.Monad.IO.Class

8import Control.Monad.IO.Class

8import Data.Semigroup ((<>))

9import Data.Semigroup ((<>))

9import qualified Data.Text as T

10import qualified Data.Text as T

10−import System.Process (proc)

12import Control.Monad.Catch (MonadMask)

14import Obelisk.CliApp

16cliDemo

17− :: ( MonadIO m, MonadMask m

17+ :: ( MonadIO m, MonadMask m, MonadFail m

18 , CliLog m, HasCliConfig e m, CliThrow e m, AsProcessFailure e, AsUnstructuredError e)

19 => m ()

20cliDemo = withSpinner "CLI Demo" $ do

lib/cliapp/src/Obelisk/CliApp/Process.hs+86−38

@@ -9,44 +9,78 @@

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

22 , reconstructCommand

25 , reconstructCommand

26+ , setCwd

27+ , setDelegateCtlc

28+ , setEnvOverride

29+ , shell

23 ) where

30 ) where

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

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

26import Control.Monad.Except (throwError)

33import Control.Monad.Except (throwError)

34+import Control.Monad.Fail

27import Control.Monad.IO.Class (MonadIO, liftIO)

35import Control.Monad.IO.Class (MonadIO, liftIO)

28import Control.Lens (Prism', review)

36import Control.Lens (Prism', review)

29import qualified Data.ByteString as BS

37import qualified Data.ByteString as BS

30import qualified Data.ByteString.Char8 as BSC

38import qualified Data.ByteString.Char8 as BSC

31import Data.Function (fix)

39import Data.Function (fix)

40+import Data.Map (Map)

41+import qualified Data.Map as Map

32import Data.Monoid ((<>))

42import Data.Monoid ((<>))

33import Data.Text (Text)

43import Data.Text (Text)

34import qualified Data.Text as T

44import qualified Data.Text as T

35import qualified Data.Text.Encoding as T

45import qualified Data.Text.Encoding as T

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

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

47+import System.Environment (getEnvironment)

37import System.Exit (ExitCode (..))

48import System.Exit (ExitCode (..))

38import System.IO (Handle)

49import System.IO (Handle)

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

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

40import qualified System.IO.Streams as Streams

51import qualified System.IO.Streams as Streams

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

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

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

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

43− waitForProcess)

44import qualified System.Process as Process

54import qualified System.Process as Process

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

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

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

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

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

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

60+data ProcessSpec = ProcessSpec

61+ { _processSpec_createProcess :: !CreateProcess

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

63+ }

64+

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

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

67+

68+shell :: String -> ProcessSpec

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

70+

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

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

73+

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

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

76+

77+setDelegateCtlc :: Bool -> ProcessSpec -> ProcessSpec

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

79+

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

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

82+

83+

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

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

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

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

52 deriving Show

86 deriving Show

@@ -60,8 +94,8 @@ instance AsProcessFailure ProcessFailure where

60 asProcessFailure = id

94 asProcessFailure = id

62readProcessAndLogStderr

96readProcessAndLogStderr

63− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

97+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

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

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

65readProcessAndLogStderr sev process = do

99readProcessAndLogStderr sev process = do

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

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

67 streamToLog =<< liftIO (streamHandle sev err)

101 streamToLog =<< liftIO (streamHandle sev err)

@@ -69,9 +103,10 @@ readProcessAndLogStderr sev process = do

103

70readCreateProcessWithExitCode

104readCreateProcessWithExitCode

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

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

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

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

73−readCreateProcessWithExitCode process = do

107+readCreateProcessWithExitCode procSpec = do

108+ process <- mkCreateProcess procSpec

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

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

75 liftIO $ Process.readCreateProcessWithExitCode process ""

110 liftIO $ Process.readCreateProcessWithExitCode process ""

111

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

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

@@ -82,11 +117,11 @@ readCreateProcessWithExitCode process = do

82-- which case it is advisable to call it with a non-Error severity for stderr, like

117-- which case it is advisable to call it with a non-Error severity for stderr, like

83-- `callProcessAndLogOutput (Debug, Debug)`.

118-- `callProcessAndLogOutput (Debug, Debug)`.

84readProcessAndLogOutput

119readProcessAndLogOutput

85− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

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

86− => (Severity, Severity) -> CreateProcess -> m Text

121+ => (Severity, Severity) -> ProcessSpec -> m Text

87readProcessAndLogOutput (sev_out, sev_err) process = do

122readProcessAndLogOutput (sev_out, sev_err) process = do

88− (_, Just out, Just err, p) <- createProcess $ process

123+ (_, Just out, Just err, p) <- createProcess $ overCreateProcess

89− { std_out = CreatePipe , std_err = CreatePipe }

124+ (\p -> p { std_out = CreatePipe , std_err = CreatePipe }) process

125

91 -- TODO interleave stdout and stderr in log correctly

126 -- TODO interleave stdout and stderr in log correctly

92 streamToLog =<< liftIO (streamHandle sev_err err)

127 streamToLog =<< liftIO (streamHandle sev_err err)

@@ -95,9 +130,9 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

130

96 liftIO (waitForProcess p) >>= \case

131 liftIO (waitForProcess p) >>= \case

97 ExitSuccess -> pure outText

132 ExitSuccess -> pure outText

98− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code

133+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code

134

100−-- | Like `System.Process.callProcess` but logs the combined output (stdout and stderr)

135+-- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)

101-- with the corresponding severity.

136-- with the corresponding severity.

102--

137--

103-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However

138-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However

@@ -105,9 +140,8 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

105-- which case it is advisable to call it with a non-Error severity for stderr, like

140-- which case it is advisable to call it with a non-Error severity for stderr, like

106-- `callProcessAndLogOutput (Debug, Debug)`.

141-- `callProcessAndLogOutput (Debug, Debug)`.

107callProcessAndLogOutput

142callProcessAndLogOutput

108−

109− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

143+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

110− => (Severity, Severity) -> CreateProcess -> m ()

144+ => (Severity, Severity) -> ProcessSpec -> m ()

111callProcessAndLogOutput (sev_out, sev_err) process =

145callProcessAndLogOutput (sev_out, sev_err) process =

112 void $ withProcess process $ \out err -> do

146 void $ withProcess process $ \out err -> do

113 stream <- liftIO $ join $ combineStream

147 stream <- liftIO $ join $ combineStream

@@ -117,21 +151,31 @@ callProcessAndLogOutput (sev_out, sev_err) process =

117 where

151 where

118 combineStream s1 s2 = concurrentMerge [s1, s2]

152 combineStream s1 s2 = concurrentMerge [s1, s2]

119

153

120−-- | Like `System.Process.createProcess` but also logs (debug) the process being run

154+-- | Like 'System.Process.createProcess' but also logs (debug) the process being run

121createProcess

155createProcess

122 :: (MonadIO m, CliLog m)

156 :: (MonadIO m, CliLog m)

123− => CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

157+ => ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

124−createProcess p = do

158+createProcess procSpec = do

159+ p <- mkCreateProcess procSpec

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

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

126 liftIO $ Process.createProcess p

161 liftIO $ Process.createProcess p

127

162

128-- | Like `System.Process.createProcess_` but also logs (debug) the process being run

163-- | Like `System.Process.createProcess_` but also logs (debug) the process being run

129createProcess_

164createProcess_

130 :: (MonadIO m, CliLog m)

165 :: (MonadIO m, CliLog m)

131− => String -> CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

166+ => String -> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

132−createProcess_ name p = do

167+createProcess_ name procSpec = do

168+ p <- mkCreateProcess procSpec

133− putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructCommand (cmdspec p)

169+ putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructProcSpec procSpec

134− liftIO $ Process.createProcess p

170+ liftIO $ Process.createProcess_ name p

171+

172+mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess

173+mkCreateProcess (ProcessSpec p override') = do

174+ case override' of

175+ Nothing -> pure p

176+ Just override -> do

177+ procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)

178+ pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }

135

179

136-- | Like `System.Process.callProcess` but also logs (debug) the process being run

180-- | Like `System.Process.callProcess` but also logs (debug) the process being run

137callProcess

181callProcess

@@ -150,18 +194,18 @@ callCommand cmd = do

150 liftIO $ Process.callCommand cmd

194 liftIO $ Process.callCommand cmd

151

195

152withProcess

196withProcess

153− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

197+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

154− => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)

198+ => ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)

155withProcess process f = do -- TODO: Use bracket.

199withProcess process f = do -- TODO: Use bracket.

156 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.

200 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.

157− (_, Just out, Just err, p) <- createProcess $ process

201+ (_, Just out, Just err, p) <- createProcess $ overCreateProcess

158− { std_out = CreatePipe , std_err = CreatePipe }

202+ (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process

159

203

160 f out err -- Pass the handles to the passed function

204 f out err -- Pass the handles to the passed function

161

205

162 liftIO (waitForProcess p) >>= \case

206 liftIO (waitForProcess p) >>= \case

163 ExitSuccess -> return (out, err)

207 ExitSuccess -> return (out, err)

164− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code

208+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code

165

209

166-- Create an input stream from the file handle, associating each item with the given severity.

210-- Create an input stream from the file handle, associating each item with the given severity.

167streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))

211streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))

@@ -178,8 +222,12 @@ streamToLog stream = fix $ \loop -> do

178

222

179-- | Pretty print a 'CmdSpec'

223-- | Pretty print a 'CmdSpec'

180reconstructCommand :: Process.CmdSpec -> Text

224reconstructCommand :: Process.CmdSpec -> Text

225+reconstructCommand p = case p of

181−reconstructCommand (Process.ShellCommand str) = T.pack str

226+ Process.ShellCommand str -> T.pack str

182−reconstructCommand (Process.RawCommand c as) = processToShellString c as

227+ Process.RawCommand c as -> processToShellString c as

183 where

228 where

184 processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)

229 processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)

185 quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

230 quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

231+

232+reconstructProcSpec :: ProcessSpec -> Text

233+reconstructProcSpec = reconstructCommand . Process.cmdspec . _processSpec_createProcess

lib/cliapp/src/Obelisk/CliApp/Types.hs+7−3

@@ -6,12 +6,14 @@

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE StandaloneDeriving #-}

9{-# LANGUAGE UndecidableInstances #-}

10{-# LANGUAGE UndecidableInstances #-}

10module Obelisk.CliApp.Types where

11module Obelisk.CliApp.Types where

12import Control.Concurrent.MVar (MVar)

13import Control.Concurrent.MVar (MVar)

13import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

14import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

15+import Control.Monad.Fail (MonadFail)

14−import Control.Monad.Log (LoggingT, MonadLog, Severity (..), WithSeverity (..), logMessage)

16+import Control.Monad.Log (LoggingT(..), MonadLog, Severity (..), WithSeverity (..), logMessage)

15import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT)

17import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT)

16import Control.Monad.Writer (WriterT)

18import Control.Monad.Writer (WriterT)

17import Control.Monad.State (StateT)

19import Control.Monad.State (StateT)

@@ -45,9 +47,11 @@ type CliThrow e m = MonadError e m

45putLog :: CliLog m => Severity -> Text -> m ()

47putLog :: CliLog m => Severity -> Text -> m ()

46putLog sev = logMessage . Output_Log . WithSeverity sev

48putLog sev = logMessage . Output_Log . WithSeverity sev

50+deriving instance MonadFail m => MonadFail (LoggingT Output m)

51+

48newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, Int)) (LoggingT Output m) a }

52newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, Int)) (LoggingT Output m) a }

49 deriving

53 deriving

50− ( Functor, Applicative, Monad, MonadIO

54+ ( Functor, Applicative, Monad, MonadIO, MonadFail

51 , MonadThrow, MonadCatch, MonadMask

55 , MonadThrow, MonadCatch, MonadMask

52 , MonadLog Output

56 , MonadLog Output

53 )

57 )

@@ -114,7 +118,7 @@ newtype CliT e m a = CliT

114 { unCliT :: ReaderT (CliConfig e) (DieT e m) a

118 { unCliT :: ReaderT (CliConfig e) (DieT e m) a

115 }

119 }

116 deriving

120 deriving

117− ( Functor, Applicative, Monad, MonadIO

121+ ( Functor, Applicative, Monad, MonadIO, MonadFail

118 , MonadThrow, MonadCatch, MonadMask

122 , MonadThrow, MonadCatch, MonadMask

119 , MonadLog Output -- CliLog

123 , MonadLog Output -- CliLog

120 , MonadError e -- CliThrow

124 , MonadError e -- CliThrow

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

@@ -1,5 +1,5 @@

1name: obelisk-command

2−version: 0.1

2+version: 0.4

3cabal-version: >= 1.8

4build-type: Simple

@@ -23,7 +23,7 @@ library

23 , filepath

24 , github

25 , here

26− , hit

26+ , git

27 , hnix

28 , hpack

29 , io-streams

@@ -46,6 +46,7 @@ library

46 , transformers

47 , unix

48 , unordered-containers

49+ , which

49 , yaml

50 , yaml

50 exposed-modules:

51 exposed-modules:

51 Obelisk.App

52 Obelisk.App

lib/command/src/Obelisk/App.hs+5−2

@@ -12,6 +12,7 @@ module Obelisk.App where

13import Control.Lens

14import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

15+import Control.Monad.Fail (MonadFail)

15import Control.Monad.Reader (MonadIO, ReaderT (..), ask, runReaderT)

16import Control.Monad.Reader (MonadIO, ReaderT (..), ask, runReaderT)

16import Control.Monad.Writer (WriterT)

17import Control.Monad.Writer (WriterT)

17import Control.Monad.State (StateT)

18import Control.Monad.State (StateT)

@@ -61,10 +62,11 @@ newtype ObeliskT m a = ObeliskT

61 { unObeliskT :: ReaderT Obelisk (CliT ObeliskError m) a

62 { unObeliskT :: ReaderT Obelisk (CliT ObeliskError m) a

62 }

63 }

63 deriving

64 deriving

64− ( Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask

65+ ( Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadFail

65 , MonadLog Output -- CliLog

66 , MonadLog Output -- CliLog

66 , MonadError ObeliskError -- CliThrow ObeliskError

67 , MonadError ObeliskError -- CliThrow ObeliskError

67− , HasCliConfig ObeliskError)

68+ , HasCliConfig ObeliskError

69+ )

69instance MonadTrans ObeliskT where

71instance MonadTrans ObeliskT where

70 lift = ObeliskT . lift . lift

72 lift = ObeliskT . lift . lift

@@ -104,6 +106,7 @@ type MonadInfallibleObelisk m =

104type MonadObelisk m =

106type MonadObelisk m =

105 ( MonadInfallibleObelisk m

107 ( MonadInfallibleObelisk m

106 , CliThrow ObeliskError m

108 , CliThrow ObeliskError m

109+ , MonadFail m

107 )

110 )

108

111

109getObeliskUserStateDir :: IO FilePath

112getObeliskUserStateDir :: IO FilePath

lib/command/src/Obelisk/Command.hs+56−17

@@ -13,6 +13,7 @@ import qualified Data.Binary as Binary

13import Data.Bool (bool)

14import qualified Data.ByteString.Base16 as Base16

15import qualified Data.ByteString.Lazy as LBS

16+import Data.Foldable (for_)

16import Data.List

17import Data.List

17import Data.Maybe (catMaybes)

18import Data.Maybe (catMaybes)

18import qualified Data.Text as T

19import qualified Data.Text as T

@@ -20,6 +21,7 @@ import Data.Text.Encoding

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

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

21import GHC.StaticPtr

22import GHC.StaticPtr

22import Options.Applicative

23import Options.Applicative

24+import Options.Applicative.Help.Pretty (text, (<$$>))

23import System.Directory

25import System.Directory

24import System.Environment

26import System.Environment

25import System.FilePath

27import System.FilePath

@@ -93,6 +95,7 @@ data ObCommand

93 | ObCommand_Repl

95 | ObCommand_Repl

94 | ObCommand_Watch

96 | ObCommand_Watch

95 | ObCommand_Shell ShellOpts

97 | ObCommand_Shell ShellOpts

98+ | ObCommand_Doc String [String] -- shell and list of packages

96 | ObCommand_Internal ObInternal

99 | ObCommand_Internal ObInternal

97 deriving Show

100 deriving Show

101

@@ -104,7 +107,7 @@ data ObInternal

104inNixShell' :: MonadObelisk m => StaticPtr (ObeliskT IO ()) -> m ()

107inNixShell' :: MonadObelisk m => StaticPtr (ObeliskT IO ()) -> m ()

105inNixShell' p = withProjectRoot "." $ \root -> do

108inNixShell' p = withProjectRoot "." $ \root -> do

106 cmd <- liftIO $ unwords <$> mkCmd -- TODO: shell escape instead of unwords

109 cmd <- liftIO $ unwords <$> mkCmd -- TODO: shell escape instead of unwords

107− projectShell root False "ghc" (Just cmd)

110+ projectShell root True "ghc" (Just cmd)

108 where

111 where

109 mkCmd = do

112 mkCmd = do

110 argsCfg <- getArgsConfig

113 argsCfg <- getArgsConfig

@@ -129,6 +132,11 @@ obCommand cfg = hsubparser

129 , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"

132 , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"

130 , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"

133 , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"

131 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"

134 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"

135+ , command "doc" $ info (ObCommand_Doc <$> shellFlags <*> packageNames) $

136+ progDesc "List paths to haddock documentation for specified packages"

137+ <> footerDoc (Just $

138+ text "Hint: To open the documentation you can pipe the output of this command like"

139+ <$$> text "ob doc reflex reflex-dom-core | xargs -n1 xdg-open")

132 ])

140 ])

133 <|> subparser

141 <|> subparser

134 (mconcat

142 (mconcat

@@ -136,6 +144,9 @@ obCommand cfg = hsubparser

136 , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)

144 , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)

137 ])

145 ])

138

146

147+packageNames :: Parser [String]

148+packageNames = some (strArgument (metavar "PACKAGE-NAME..."))

149+

139deployCommand :: ArgsConfig -> Parser DeployCommand

150deployCommand :: ArgsConfig -> Parser DeployCommand

140deployCommand cfg = hsubparser $ mconcat

151deployCommand cfg = hsubparser $ mconcat

141 [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"

152 [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"

@@ -210,20 +221,35 @@ thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgumen

210 , help "Path to directory containing thunk data"

221 , help "Path to directory containing thunk data"

211 ]

222 ]

212

223

224+thunkConfig :: Parser ThunkConfig

225+thunkConfig = ThunkConfig

226+ <$>

227+ ( flag' (Just True) (long "private" <> help "Mark thunks as pointing to a private repository")

228+ <|> flag' (Just False) (long "public" <> help "Mark thunks as pointing to a public repository")

229+ <|> pure Nothing

230+ )

231+

232+thunkUpdateConfig :: Parser ThunkUpdateConfig

233+thunkUpdateConfig = ThunkUpdateConfig

234+ <$> optional (strOption (long "branch" <> metavar "BRANCH" <> help "Use the given branch when looking for the latest revision"))

235+ <*> thunkConfig

236+

237+thunkPackConfig :: Parser ThunkPackConfig

238+thunkPackConfig = ThunkPackConfig

239+ <$> 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.")

240+ <*> thunkConfig

241+

213data ThunkCommand

242data ThunkCommand

214− = ThunkCommand_Update [FilePath] (Maybe String)

243+ = ThunkCommand_Update [FilePath] ThunkUpdateConfig

215 | ThunkCommand_Unpack [FilePath]

244 | ThunkCommand_Unpack [FilePath]

216− | ThunkCommand_Pack [FilePath] Bool

245+ | ThunkCommand_Pack [FilePath] ThunkPackConfig

217 deriving Show

246 deriving Show

218

247

219−forceFlag :: Parser Bool

220−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."

221−

222thunkCommand :: Parser ThunkCommand

248thunkCommand :: Parser ThunkCommand

223thunkCommand = hsubparser $ mconcat

249thunkCommand = hsubparser $ mconcat

224− [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> optional (strOption (long "branch" <> metavar "BRANCH"))) $ progDesc "Update thunk to latest revision available"

250+ [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> thunkUpdateConfig) $ progDesc "Update thunk to latest revision available"

225 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

251 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

226− , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> forceFlag) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"

252+ , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> thunkPackConfig) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"

227 ]

253 ]

228

254

229data ShellOpts

255data ShellOpts

@@ -233,12 +259,15 @@ data ShellOpts

233 }

259 }

234 deriving Show

260 deriving Show

235

261

262+shellFlags :: Parser String

263+shellFlags =

264+ flag' "ghc" (long "ghc" <> help "Enter a shell environment having ghc (default)")

265+ <|> flag "ghc" "ghcjs" (long "ghcjs" <> help "Enter a shell having ghcjs rather than ghc")

266+ <|> strOption (short 'A' <> long "argument" <> metavar "NIXARG" <> help "Use the environment specified by the given nix argument of `shells'")

267+

236shellOpts :: Parser ShellOpts

268shellOpts :: Parser ShellOpts

237shellOpts = ShellOpts

269shellOpts = ShellOpts

238− <$> ( flag' "ghc" (long "ghc" <> help "Enter a shell environment having ghc (default)")

270+ <$> shellFlags

239− <|> flag "ghc" "ghcjs" (long "ghcjs" <> help "Enter a shell having ghcjs rather than ghc")

240− <|> strOption (short 'A' <> long "argument" <> metavar "NIXARG" <> help "Use the environment specified by the given nix argument of `shells'")

241− )

242 <*> optional (strArgument (metavar "COMMAND"))

271 <*> optional (strArgument (metavar "COMMAND"))

243

272

244parserPrefs :: ParserPrefs

273parserPrefs :: ParserPrefs

@@ -254,7 +283,8 @@ mkObeliskConfig :: IO Obelisk

254mkObeliskConfig = do

283mkObeliskConfig = do

255 cliArgs <- getArgs

284 cliArgs <- getArgs

256 -- This function should not use argument parser (full argument parsing happens post handoff)

285 -- This function should not use argument parser (full argument parsing happens post handoff)

286+ -- TODO: See if we can use the argument parser with a subset of the parsers to get logging level out.

257− let logLevel = toLogLevel $ "-v" `elem` cliArgs

287+ let logLevel = toLogLevel $ any (`elem` ["-v", "--verbose"]) cliArgs

258 notInteractive <- not <$> isInteractiveTerm

288 notInteractive <- not <$> isInteractiveTerm

259 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

289 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

260 ObeliskError_ProcessError (ProcessFailure p code) ann ->

290 ObeliskError_ProcessError (ProcessFailure p code) ann ->

@@ -360,15 +390,16 @@ ob = \case

360 DeployCommand_Update -> deployUpdate "."

390 DeployCommand_Update -> deployUpdate "."

361 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs

391 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs

362 ObCommand_Run -> inNixShell' $ static run

392 ObCommand_Run -> inNixShell' $ static run

363− -- inNixShell ($(mkClosure 'ghcidAction) ())

364 ObCommand_Thunk tc -> case tc of

393 ObCommand_Thunk tc -> case tc of

365− ThunkCommand_Update thunks mBranch -> mapM_ ((flip updateThunkToLatest) mBranch) thunks

394+ ThunkCommand_Update thunks config -> for_ thunks (updateThunkToLatest config)

366− ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

395+ ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

367− ThunkCommand_Pack thunks force -> forM_ thunks (packThunk force)

396+ ThunkCommand_Pack thunks config -> for_ thunks (packThunk config)

368 ObCommand_Repl -> runRepl

397 ObCommand_Repl -> runRepl

369 ObCommand_Watch -> inNixShell' $ static runWatch

398 ObCommand_Watch -> inNixShell' $ static runWatch

370 ObCommand_Shell so -> withProjectRoot "." $ \root ->

399 ObCommand_Shell so -> withProjectRoot "." $ \root ->

371 projectShell root False (_shellOpts_shell so) (_shellOpts_command so)

400 projectShell root False (_shellOpts_shell so) (_shellOpts_command so)

401+ ObCommand_Doc shell' pkgs -> withProjectRoot "." $ \root ->

402+ projectShell root False shell' (Just $ haddockCommand pkgs)

372 ObCommand_Internal icmd -> case icmd of

403 ObCommand_Internal icmd -> case icmd of

373 ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case

404 ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case

374 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)

405 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)

@@ -377,6 +408,14 @@ ob = \case

377 liftIO $ runObelisk c $ deRefStaticPtr p

408 liftIO $ runObelisk c $ deRefStaticPtr p

378 ObInternal_CLIDemo -> cliDemo

409 ObInternal_CLIDemo -> cliDemo

379

410

411+haddockCommand :: [String] -> String

412+haddockCommand pkgs = unwords

413+ [ "for p in"

414+ , unwords [getHaddockPath p ++ "/index.html" | p <- pkgs]

415+ , "; do echo $p; done"

416+ ]

417+ where getHaddockPath p = "$(ghc-pkg field " ++ p ++ " haddock-html --simple-output)"

418+

380--TODO: Clean up all the magic strings throughout this codebase

419--TODO: Clean up all the magic strings throughout this codebase

381

420

382getArgsConfig :: IO ArgsConfig

421getArgsConfig :: IO ArgsConfig

lib/command/src/Obelisk/Command/Deploy.hs+29−29

@@ -4,7 +4,6 @@

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ViewPatterns #-}

6{-# LANGUAGE DeriveGeneric #-}

7−{-# LANGUAGE TypeApplications #-}

8module Obelisk.Command.Deploy where

7module Obelisk.Command.Deploy where

10import Control.Lens

9import Control.Lens

@@ -22,26 +21,27 @@ import qualified Data.Set as Set

22import qualified Data.Text as T

21import qualified Data.Text as T

23import qualified Data.Text.IO as T

22import qualified Data.Text.IO as T

24import GHC.Generics

23import GHC.Generics

25−import Nix.Convert

26import Nix.Pretty

24import Nix.Pretty

25+import Nix.String (principledMakeNixStringWithoutContext)

27import Nix.Value

26import Nix.Value

28import System.Directory

27import System.Directory

29−import System.Environment (getEnvironment)

30import System.FilePath

28import System.FilePath

31import System.IO

29import System.IO

32import System.Posix.Files

30import System.Posix.Files

33−import System.Process (delegate_ctlc, env, proc, cwd)

34import Text.URI (URI)

31import Text.URI (URI)

35import qualified Text.URI as URI

32import qualified Text.URI as URI

36import Text.URI.Lens

33import Text.URI.Lens

38import Obelisk.App (MonadObelisk)

35import Obelisk.App (MonadObelisk)

36+import Obelisk.CliApp (

39−import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, failWith, putLog, withSpinner)

37+ Severity (..), callProcessAndLogOutput, failWith, proc, putLog,

38+ setCwd, setDelegateCtlc, setEnvOverride, withSpinner)

40import Obelisk.Command.Nix

39import Obelisk.Command.Nix

41import Obelisk.Command.Project

40import Obelisk.Command.Project

42import Obelisk.Command.Thunk

41import Obelisk.Command.Thunk

43import Obelisk.Command.Utils

42import Obelisk.Command.Utils

44+

45deployInit

46 :: MonadObelisk m

47 => ThunkPtr

@@ -58,7 +58,7 @@ deployInit thunkPtr deployDir sshKeyPath hostnames route adminEmail enableHttps

58 False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath

59 True -> pure $ deployDir </> "ssh_key"

60 callProcessAndLogOutput (Notice, Error) $

61− proc "cp" [sshKeyPath, localKey]

61+ proc cp [sshKeyPath, localKey]

62 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode

63 return localKey

64 withSpinner "Validating configuration" $ do

@@ -83,7 +83,7 @@ deployInit thunkPtr deployDir sshKeyPath hostnames route adminEmail enableHttps

83 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames

84 writeDeployConfig deployDir "enable_https" $ show enableHttps

85 writeDeployConfig deployDir "admin_email" adminEmail

86− writeDeployConfig deployDir ("config" </> "common" </> "route") $ route

86+ writeDeployConfig deployDir ("config" </> "common" </> "route") route

87 withSpinner "Creating source thunk (./src)" $ liftIO $ do

88 createThunk (deployDir </> "src") thunkPtr

89 setupObeliskImpl deployDir

@@ -108,7 +108,7 @@ deployPush deployPath getNixBuilders = do

108 Right (ThunkData_Packed ptr) -> return ptr

109 Right (ThunkData_Checkout _) -> do

110 checkGitCleanStatus srcPath True >>= \case

111− True -> packThunk False srcPath

111+ True -> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath

112 False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."

113 Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)

114 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr

@@ -158,7 +158,7 @@ deployPush deployPath getNixBuilders = do

158 ]

159 isClean <- checkGitCleanStatus deployPath True

160 when (not isClean) $ do

161− withSpinner "Commiting changes to Git" $ do

161+ withSpinner "Committing changes to Git" $ do

162 callProcessAndLogOutput (Debug, Error) $ proc "git"

163 ["-C", deployPath, "add", "."]

164 callProcessAndLogOutput (Debug, Error) $ proc "git"

@@ -166,20 +166,20 @@ deployPush deployPath getNixBuilders = do

166 putLog Notice $ "Deployed => " <> T.pack route

167 where

168 callProcess' envMap cmd args = do

169− processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment

169+ let p = setEnvOverride (envMap <>) $ setDelegateCtlc True $ proc cmd args

170− let p = (proc cmd args) { delegate_ctlc = True, env = Just processEnv }

171 callProcessAndLogOutput (Notice, Notice) p

170 callProcessAndLogOutput (Notice, Notice) p

172

171

173deployUpdate :: MonadObelisk m => FilePath -> m ()

172deployUpdate :: MonadObelisk m => FilePath -> m ()

174−deployUpdate deployPath = updateThunkToLatest (deployPath </> "src") Nothing

173+deployUpdate deployPath = updateThunkToLatest (ThunkUpdateConfig Nothing (ThunkConfig Nothing)) (deployPath </> "src")

175

174

176−keytoolToAndroidConfig :: KeytoolConfig -> HM.HashMap Text (NValueNF Identity)

175+keytoolToAndroidConfig :: KeytoolConfig -> HM.HashMap Text (NValue t Identity m)

177−keytoolToAndroidConfig conf = runIdentity $ do

176+keytoolToAndroidConfig conf =

178− path <- toValue $ Path $ _keytoolConfig_keystore conf

177+ let path = nvPath $ _keytoolConfig_keystore conf

178+ fromStr = nvStr . principledMakeNixStringWithoutContext . T.pack

179− storepass <- toValue $ T.pack $ _keytoolConfig_storepass conf

179+ storepass = fromStr $ _keytoolConfig_storepass conf

180− alias <- toValue $ T.pack $ _keytoolConfig_alias conf

180+ alias = fromStr $ _keytoolConfig_alias conf

181− keypass <- toValue $ T.pack $ _keytoolConfig_keypass conf

181+ keypass = fromStr $ _keytoolConfig_keypass conf

182− return $ HM.fromList

182+ in HM.fromList

183 [ ("storeFile", path)

184 , ("storePassword", storepass)

185 , ("keyAlias", alias)

@@ -194,7 +194,7 @@ renderPlatformDeployment = \case

194 Android -> "android"

195 IOS -> "ios"

196

197−deployMobile :: MonadObelisk m => PlatformDeployment -> [String] -> m ()

197+deployMobile :: forall m. MonadObelisk m => PlatformDeployment -> [String] -> m ()

198deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

199 let srcDir = root </> "src"

200 configDir = root </> "config"

@@ -219,17 +219,17 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

219 , _keytoolConfig_storepass = keyStorePassword

220 , _keytoolConfig_keypass = keyStorePassword

221 }

222− createKeystore root $ keyToolConf

222+ createKeystore root keyToolConf

223 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

224 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

225 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

226 keytoolConfContents <- liftIO $ BSL.readFile keytoolConfPath

227− liftIO $ putStrLn $ show keytoolConfContents

227+ liftIO $ print keytoolConfContents

228− releaseKey <- case eitherDecode keytoolConfContents of

228+ releaseKey :: String <- case eitherDecode keytoolConfContents :: Either String KeytoolConfig of

229 Left err -> failWith $ T.pack err

230− Right conf -> do

230+ Right conf -> return $

231− let nvset = toValue @(HM.HashMap Text (NValueNF Identity)) @Identity @(NValueNF Identity) $ keytoolToAndroidConfig conf

231+ (printNix :: MonadObelisk m => NValue t Identity m -> String) $

232− return $ printNix $ runIdentity nvset

232+ nvSet (keytoolToAndroidConfig conf) HM.empty

233 let expr = mconcat

234 [ "with (import ", srcDir, " {});"

235 , "android.frontend.override (drv: { "

@@ -255,7 +255,7 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

255 result <- nixCmd $ NixCmd_Build $ def

256 & nixBuildConfig_outLink .~ OutLink_None

257 & nixCmdConfig_target .~ nixBuildTarget

258− putLog Notice $ T.pack $ "Your recently built android apk can be found at the following path: " <> (show result)

258+ putLog Notice $ T.pack $ "Your recently built android apk can be found at the following path: " <> show result

259 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs

260 where

261 withEcho showEcho f = do

@@ -275,13 +275,13 @@ instance ToJSON KeytoolConfig

275createKeystore :: MonadObelisk m => FilePath -> KeytoolConfig -> m ()

276createKeystore root config = do

277 let expr = "with (import " <> toImplDir root <> ").reflex-platform.nixpkgs; pkgs.mkShell { buildInputs = [ pkgs.jdk ]; }"

278− callProcessAndLogOutput (Notice,Notice) $ (proc "nix-shell" ["-E" , expr, "--run" , keytoolCmd]) { cwd = Just root }

278+ callProcessAndLogOutput (Notice,Notice) $ setCwd (Just root) $ proc "nix-shell" ["default.nix", "-E" , expr, "--run" , keytoolCmd]

279 where

280 keytoolCmd = processToShellString "keytool"

281 [ "-genkeypair", "-noprompt"

282 , "-keystore", _keytoolConfig_keystore config

283 , "-keyalg", "RSA", "-keysize", "2048"

284− , "-validity", "1000000000"

284+ , "-validity", "1000000"

285 , "-storepass", _keytoolConfig_storepass config

286 , "-alias", _keytoolConfig_alias config

287 , "-keypass", _keytoolConfig_keypass config

lib/command/src/Obelisk/Command/Nix.hs+1−2

@@ -37,7 +37,6 @@ import Data.List (intercalate)

37import Data.Maybe

38import Data.Monoid ((<>))

39import qualified Data.Text as T

40−import System.Process (proc)

42import Obelisk.App (MonadObelisk)

41import Obelisk.App (MonadObelisk)

43import Obelisk.CliApp

42import Obelisk.CliApp

@@ -160,7 +159,7 @@ instance Default NixCmd where

160

159

161nixCmd :: MonadObelisk m => NixCmd -> m FilePath

160nixCmd :: MonadObelisk m => NixCmd -> m FilePath

162nixCmd cmdCfg = withSpinner' ("Running " <> cmd <> desc) (Just $ const $ "Built " <> desc) $ do

161nixCmd cmdCfg = withSpinner' ("Running " <> cmd <> desc) (Just $ const $ "Built " <> desc) $ do

163− output <- readProcessAndLogStderr Debug $ proc (T.unpack cmd) $ options

162+ output <- readProcessAndLogStderr Debug $ proc (T.unpack cmd) options

164 -- Remove final newline that Nix appends

163 -- Remove final newline that Nix appends

165 Just (outPath, '\n') <- pure $ T.unsnoc output

164 Just (outPath, '\n') <- pure $ T.unsnoc output

166 pure $ T.unpack outPath

165 pure $ T.unpack outPath

lib/command/src/Obelisk/Command/Project.hs+78−33

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

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TemplateHaskell #-}

4module Obelisk.Command.Project

5module Obelisk.Command.Project

5 ( InitSource (..)

6 ( InitSource (..)

6 , initProject

7 , initProject

@@ -15,6 +16,7 @@ module Obelisk.Command.Project

15 , toImplDir

16 , toImplDir

16 ) where

17 ) where

19+import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)

18import Control.Monad

20import Control.Monad

19import Control.Monad.IO.Class (liftIO)

21import Control.Monad.IO.Class (liftIO)

20import Control.Monad.State

22import Control.Monad.State

@@ -22,11 +24,14 @@ import Data.Bits

22import Data.Function (on)

24import Data.Function (on)

23import qualified Data.Text as T

25import qualified Data.Text as T

24import System.Directory

26import System.Directory

27+import System.Environment (lookupEnv)

25import System.FilePath

28import System.FilePath

26import System.IO.Temp

29import System.IO.Temp

30+import System.IO.Unsafe (unsafePerformIO)

27−import System.Posix (FileStatus, UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)

31+import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)

28import System.Posix.Files

32import System.Posix.Files

29−import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)

33+import System.Process (waitForProcess)

34+import System.Which (staticWhich)

31import GitHub.Data.GitData (Branch)

36import GitHub.Data.GitData (Branch)

32import GitHub.Data.Name (Name)

37import GitHub.Data.Name (Name)

@@ -34,6 +39,7 @@ import GitHub.Data.Name (Name)

34import Obelisk.App (MonadObelisk)

39import Obelisk.App (MonadObelisk)

35import Obelisk.CliApp

40import Obelisk.CliApp

36import Obelisk.Command.Thunk

41import Obelisk.Command.Thunk

42+

37--TODO: Make this module resilient to random exceptions

43--TODO: Make this module resilient to random exceptions

39--TODO: Don't hardcode this

45--TODO: Don't hardcode this

@@ -47,13 +53,14 @@ obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource

47 { _gitHubSource_owner = "obsidiansystems"

53 { _gitHubSource_owner = "obsidiansystems"

48 , _gitHubSource_repo = "obelisk"

54 , _gitHubSource_repo = "obelisk"

49 , _gitHubSource_branch = Just branch

55 , _gitHubSource_branch = Just branch

56+ , _gitHubSource_private = False

50 }

57 }

52data InitSource

59data InitSource

53− = InitSource_Default

60+ = InitSource_Default

54− | InitSource_Branch (Name Branch)

61+ | InitSource_Branch (Name Branch)

55− | InitSource_Symlink FilePath

62+ | InitSource_Symlink FilePath

56− deriving Show

63+ deriving Show

58-- | Path to obelisk directory in given path

65-- | Path to obelisk directory in given path

59toObeliskDir :: FilePath -> FilePath

66toObeliskDir :: FilePath -> FilePath

@@ -114,15 +121,16 @@ initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do

114findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

121findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

115findProjectObeliskCommand target = do

122findProjectObeliskCommand target = do

116 myUid <- liftIO getRealUserID

123 myUid <- liftIO getRealUserID

124+ processUmask <- liftIO getUmask

117 targetStat <- liftIO $ getFileStatus target

125 targetStat <- liftIO $ getFileStatus target

118− (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat myUid >>= \case

126+ (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case

119 Nothing -> pure Nothing

127 Nothing -> pure Nothing

120 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case

128 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case

121 False -> do

129 False -> do

122 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"

130 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"

123 pure Nothing

131 pure Nothing

124 True -> do

132 True -> do

125− walkToImplDir projectRoot myUid -- For security check

133+ walkToImplDir projectRoot myUid processUmask -- For security check

126 return $ Just projectRoot

134 return $ Just projectRoot

127 case (result, insecurePaths) of

135 case (result, insecurePaths) of

128 (Just projDir, []) -> do

136 (Just projDir, []) -> do

@@ -133,16 +141,36 @@ findProjectObeliskCommand target = do

133 putLog Error $ T.unlines

141 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:"

142 [ "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

143 , 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."

144+ , "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 ]

145 ]

138 return Nothing

146 return Nothing

139

147

148+-- | Get the umask for the Obelisk process.

149+--

150+-- Because of

151+-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the

152+-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and

153+-- reading isn't interrupted by any exception or interleaved with another thread.

154+getUmask :: IO FileMode

155+getUmask = withMVarMasked globalUmaskLock $ \() -> do

156+ initialMask <- setFileCreationMask safeUmask

157+ void (setFileCreationMask initialMask)

158+ pure initialMask

159+ where

160+ safeUmask :: FileMode

161+ safeUmask = CMode 0o22

162+

163+{-# NOINLINE globalUmaskLock #-}

164+globalUmaskLock :: MVar ()

165+globalUmaskLock = unsafePerformIO (newMVar ())

166+

140-- | Get the FilePath to the containing project directory, if there is one

167-- | Get the FilePath to the containing project directory, if there is one

141findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

168findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

142findProjectRoot target = do

169findProjectRoot target = do

143 myUid <- liftIO getRealUserID

170 myUid <- liftIO getRealUserID

144 targetStat <- liftIO $ getFileStatus target

171 targetStat <- liftIO $ getFileStatus target

172+ umask <- liftIO getUmask

145− (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []

173+ (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []

146 return result

174 return result

147

175

148withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a

176withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a

@@ -155,15 +183,15 @@ withProjectRoot target f = findProjectRoot target >>= \case

155-- traversed in the process. Return the project root directory, if found.

183-- traversed in the process. Return the project root directory, if found.

156walkToProjectRoot

184walkToProjectRoot

157 :: (MonadState [FilePath] m, MonadIO m)

185 :: (MonadState [FilePath] m, MonadIO m)

158− => FilePath -> FileStatus -> UserID -> m (Maybe FilePath)

186+ => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)

159−walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \case

187+walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case

160 -- It's not a directory, so it can't be a project

188 -- It's not a directory, so it can't be a project

161 False -> do

189 False -> do

162 let dir = takeDirectory this

190 let dir = takeDirectory this

163 dirStat <- liftIO $ getFileStatus dir

191 dirStat <- liftIO $ getFileStatus dir

164− walkToProjectRoot dir dirStat myUid

192+ walkToProjectRoot dir dirStat desiredUmask myUid

165 True -> do

193 True -> do

166− when (not $ isWritableOnlyBy thisStat myUid) $ modify (this:)

194+ when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)

167 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case

195 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case

168 True -> return $ Just this

196 True -> return $ Just this

169 False -> do

197 False -> do

@@ -173,25 +201,38 @@ walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \ca

173 isSameFileAs = (==) `on` fileIdentity

201 isSameFileAs = (==) `on` fileIdentity

174 if thisStat `isSameFileAs` nextStat

202 if thisStat `isSameFileAs` nextStat

175 then return Nothing -- Found a cycle; probably hit root directory

203 then return Nothing -- Found a cycle; probably hit root directory

176− else walkToProjectRoot next nextStat myUid

204+ else walkToProjectRoot next nextStat desiredUmask myUid

177

205

178-- | Walk from the given project root directory to its Obelisk implementation

206-- | Walk from the given project root directory to its Obelisk implementation

179-- directory, accumulating potentially insecure directories that were traversed

207-- directory, accumulating potentially insecure directories that were traversed

180-- in the process.

208-- in the process.

181−walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> m ()

209+walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()

182−walkToImplDir projectRoot myUid = do

210+walkToImplDir projectRoot myUid umask = do

183 let obDir = toObeliskDir projectRoot

211 let obDir = toObeliskDir projectRoot

184 obDirStat <- liftIO $ getFileStatus obDir

212 obDirStat <- liftIO $ getFileStatus obDir

185− when (not $ isWritableOnlyBy obDirStat myUid) $ modify (obDir:)

213+ when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)

186 let implThunk = obDir </> "impl"

214 let implThunk = obDir </> "impl"

187 implThunkStat <- liftIO $ getFileStatus implThunk

215 implThunkStat <- liftIO $ getFileStatus implThunk

188− when (not $ isWritableOnlyBy implThunkStat myUid) $ modify (implThunk:)

216+ when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)

217+

218+-- | Check to see if directory is writable by a user whose User ID matches the

219+-- second argument provided, and if the fact that other people can write to that

220+-- directory is in accordance with the umask of the system, passed as the third

221+-- argument.

222+isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool

223+isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask

189

224

190−--TODO: Is there a better way to ask if anyone else can write things?

225+isOwnedBy :: FileStatus -> UserID -> Bool

191−--E.g. what about ACLs?

226+isOwnedBy s uid = fileOwner s == uid

192−-- | Check to see if directory is only writable by a user whose User ID matches the second argument provided

227+

193−isWritableOnlyBy :: FileStatus -> UserID -> Bool

228+-- | Check to see if a directory respect the umask, but check explicitly that

194−isWritableOnlyBy s uid = fileOwner s == uid && fileMode s .&. 0o22 == 0

229+-- it's not world writable in any case.

230+filePermissionIsSafe :: FileStatus -> FileMode -> Bool

231+filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable

232+ where

233+ fileWorldWritable = fileMode s .&. 0o002 == 0o002

234+ fileGroupWritable = fileMode s .&. 0o020 == 0o020

235+ umaskGroupWritable = umask .&. 0o020 == 0

195

236

196-- | Run a command in the given shell for the current project

237-- | Run a command in the given shell for the current project

197inProjectShell :: MonadObelisk m => String -> String -> m ()

238inProjectShell :: MonadObelisk m => String -> String -> m ()

@@ -204,17 +245,21 @@ inImpureProjectShell shellName command = withProjectRoot "." $ \root ->

204

245

205projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

246projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

206projectShell root isPure shellName command = do

247projectShell root isPure shellName command = do

248+ let nixPath = $(staticWhich "nix")

249+ nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $ proc nixPath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]

250+ nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"

207− (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $

251+ (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setDelegateCtlc True $ setCwd (Just root) $ proc "nix-shell" $

252+ [ "default.nix"] <>

208− [ "--pure" | isPure ] <>

253+ ["--pure" | isPure] <>

209 [ "-A"

254 [ "-A"

210 , "shells." <> shellName

255 , "shells." <> shellName

211 ] <> case command of

256 ] <> case command of

212 Nothing -> []

257 Nothing -> []

213− Just c -> ["--run", c]

258+ Just c ->

259+ -- TODO: Escape nixpkgsPath and nixRemote

260+ [ "--run"

261+ , "export NIX_PATH=nixpkgs=" <> T.unpack nixpkgsPath <> "; " <>

262+ maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote <>

263+ c

264+ ]

214 void $ liftIO $ waitForProcess ph

265 void $ liftIO $ waitForProcess ph

215−

216−setCtlc :: CreateProcess -> CreateProcess

217−setCtlc cfg = cfg { delegate_ctlc = True }

218−

219−setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess

220−setCwd fp cfg = cfg { cwd = fp }

lib/command/src/Obelisk/Command/Run.hs+100−70

@@ -3,17 +3,23 @@

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TemplateHaskell #-}

7+{-# LANGUAGE TupleSections #-}

6module Obelisk.Command.Run where

8module Obelisk.Command.Run where

10+import Control.Applicative (liftA2)

8−import Control.Exception (bracket)

11+import Control.Exception (Exception, bracket)

9import Control.Monad

12import Control.Monad

13+import Control.Monad.Except (runExceptT, throwError)

10import Control.Monad.IO.Class (liftIO)

14import Control.Monad.IO.Class (liftIO)

11import Control.Monad.Reader (MonadIO)

15import Control.Monad.Reader (MonadIO)

12import Data.Either

16import Data.Either

17+import Data.Foldable (for_)

13import qualified Data.List as L

18import qualified Data.List as L

14import qualified Data.List.NonEmpty as NE

19import qualified Data.List.NonEmpty as NE

15import Data.Maybe

20import Data.Maybe

16import qualified Data.Text as T

21import qualified Data.Text as T

22+import Distribution.Compiler (CompilerFlavor(..))

17import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)

23import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)

18import Distribution.Parsec.ParseResult (runParseResult)

24import Distribution.Parsec.ParseResult (runParseResult)

19import Distribution.Pretty

25import Distribution.Pretty

@@ -22,22 +28,18 @@ import Distribution.Types.CondTree

22import Distribution.Types.GenericPackageDescription

28import Distribution.Types.GenericPackageDescription

23import Distribution.Types.Library

29import Distribution.Types.Library

24import Distribution.Utils.Generic

30import Distribution.Utils.Generic

25−import Hpack.Config

31+import qualified Hpack.Config as Hpack

26−import Hpack.Render

32+import qualified Hpack.Render as Hpack

27−import Hpack.Yaml

33+import qualified Hpack.Yaml as Hpack

28import Language.Haskell.Extension

34import Language.Haskell.Extension

29import Network.Socket hiding (Debug)

35import Network.Socket hiding (Debug)

30import System.Directory

36import System.Directory

31import System.FilePath

37import System.FilePath

32−import System.Process (proc)

33import System.IO.Temp (withSystemTempDirectory)

38import System.IO.Temp (withSystemTempDirectory)

34−import Data.ByteString (ByteString)

39+import System.Which (staticWhich)

36import Obelisk.App (MonadObelisk, ObeliskT)

41import Obelisk.App (MonadObelisk, ObeliskT)

37−import Obelisk.CliApp

38− ( CliT (..), HasCliConfig, Severity (..)

39− , callCommand, failWith, getCliConfig, putLog

42+import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readProcessAndLogStderr)

40− , readProcessAndLogStderr, runCli)

41import Obelisk.Command.Project (inProjectShell, withProjectRoot)

43import Obelisk.Command.Project (inProjectShell, withProjectRoot)

43data CabalPackageInfo = CabalPackageInfo

45data CabalPackageInfo = CabalPackageInfo

@@ -48,11 +50,15 @@ data CabalPackageInfo = CabalPackageInfo

48 -- ^ List of globally enable extensions of the library component

50 -- ^ List of globally enable extensions of the library component

49 , _cabalPackageInfo_defaultLanguage :: Maybe Language

51 , _cabalPackageInfo_defaultLanguage :: Maybe Language

50 -- ^ List of globally set languages of the library component

52 -- ^ List of globally set languages of the library component

53+ , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]

54+ -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)

51 }

55 }

53-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.

57-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.

54run :: ObeliskT IO ()

58run :: ObeliskT IO ()

55run = do

59run = do

60+ let nixPath = $(staticWhich "nix")

61+ nixBuildPath = $(staticWhich "nix-build")

56 pkgs <- getLocalPkgs

62 pkgs <- getLocalPkgs

57 withGhciScript pkgs $ \dotGhciPath -> do

63 withGhciScript pkgs $ \dotGhciPath -> do

58 freePort <- getFreePort

64 freePort <- getFreePort

@@ -61,7 +67,7 @@ run = do

61 then root

67 then root

62 else "./" <> root

68 else "./" <> root

63 isDerivation <- readProcessAndLogStderr Debug $

69 isDerivation <- readProcessAndLogStderr Debug $

64− proc "nix"

70+ proc nixPath

65 [ "eval"

71 [ "eval"

66 , "-f"

72 , "-f"

67 , root

73 , root

@@ -73,9 +79,12 @@ run = do

73 -- Check whether the impure static files are a derivation (and so must be built)

79 -- Check whether the impure static files are a derivation (and so must be built)

74 if isDerivation == "1"

80 if isDerivation == "1"

75 then fmap T.strip $ readProcessAndLogStderr Debug $ -- Strip whitespace here because nix-build has no --raw option

81 then fmap T.strip $ readProcessAndLogStderr Debug $ -- Strip whitespace here because nix-build has no --raw option

82+ proc nixBuildPath

83+ [ "--no-out-link"

76− proc "nix-build" ["-E", "(import " <> importableRoot <> "{}).passthru.staticFilesImpure"]

84+ , "-E", "(import " <> importableRoot <> "{}).passthru.staticFilesImpure"

85+ ]

77 else readProcessAndLogStderr Debug $

86 else readProcessAndLogStderr Debug $

78− proc "nix" ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]

87+ proc nixPath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]

79 putLog Debug $ "Assets impurely loaded from: " <> assets

88 putLog Debug $ "Assets impurely loaded from: " <> assets

80 runGhcid dotGhciPath $ Just $ unwords

89 runGhcid dotGhciPath $ Just $ unwords

81 [ "Obelisk.Run.run"

90 [ "Obelisk.Run.run"

@@ -96,6 +105,27 @@ runWatch = do

96 pkgs <- getLocalPkgs

105 pkgs <- getLocalPkgs

97 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing

106 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing

107

108+data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound

109+ deriving (Eq, Ord, Show)

110+instance Exception GuessPackageFileError

111+

112+-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.

113+guessCabalPackageFile

114+ :: MonadIO m

115+ => FilePath -- ^ Directory to search for cabal package

116+ -> m (Either GuessPackageFileError (Either FilePath FilePath))

117+ -- ^ 'Right' 'Left' for hpack package, 'Right' 'Right' for cabal package; 'FilePath' is relative to given directory.

118+guessCabalPackageFile dir = do

119+ candidates <- liftIO $

120+ filterM (doesFileExist . (dir </>))

121+ =<< filter (liftA2 (||) (== Hpack.packageConfig) (".cabal" `L.isSuffixOf`))

122+ <$> listDirectory dir

123+ pure $ case L.partition (== Hpack.packageConfig) candidates of

124+ ([hpack], _) -> Right $ Left hpack

125+ ([], [cabal]) -> Right $ Right cabal

126+ ([], []) -> Left GuessPackageFileError_NotFound

127+ (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ hpacks <> cabals

128+

99-- | Relative paths to local packages of an obelisk project

129-- | Relative paths to local packages of an obelisk project

100-- TODO a way to query this

130-- TODO a way to query this

101getLocalPkgs :: Applicative f => f [FilePath]

131getLocalPkgs :: Applicative f => f [FilePath]

@@ -105,66 +135,53 @@ parseCabalPackage

105 :: (MonadObelisk m)

135 :: (MonadObelisk m)

106 => FilePath -- ^ package directory

136 => FilePath -- ^ package directory

107 -> m (Maybe CabalPackageInfo)

137 -> m (Maybe CabalPackageInfo)

108−parseCabalPackage dir = do

138+parseCabalPackage dir = either ((Nothing <$) . putLog Error) (pure . Just) <=< runExceptT $ do

109− let cabalFp = dir </> (takeBaseName dir <> ".cabal")

139+ (cabalContents, packageFile) <- guessCabalPackageFile dir >>= \case

110− hpackFp = dir </> "package.yaml"

140+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack dir

111− hasCabal <- liftIO $ doesFileExist cabalFp

141+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack dir

112− hasHpack <- liftIO $ doesFileExist hpackFp

142+ Right (Right cabalFileName) -> let file = dir </> cabalFileName in (, file) <$> liftIO (readUTF8File file)

113−

143+ Right (Left hpackFileName) -> do

114− mCabalContents <- if hasCabal

144+ let

115− then Just <$> liftIO (readUTF8File cabalFp)

145+ file = dir </> hpackFileName

116− else if hasHpack

117− then do

118− let decodeOptions = DecodeOptions hpackFp Nothing decodeYaml

146+ decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml

119− liftIO (readPackageConfig decodeOptions) >>= \case

147+ liftIO (Hpack.readPackageConfig decodeOptions) >>= \case

120− Left err -> do

121− putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err

148+ Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err

122− return Nothing

123− Right (DecodeResult hpackPackage _ _) -> do

149+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file)

124− return $ Just $ renderPackage [] hpackPackage

150+

125− else return Nothing

126−

127− fmap join $ forM mCabalContents $ \cabalContents -> do

128− let (warnings, result) = runParseResult $ parseGenericPackageDescription $

151+ let (warnings, result) = runParseResult $ parseGenericPackageDescription $

129− toUTF8BS $ cabalContents

152+ toUTF8BS cabalContents

130− mapM_ (putLog Warning) $ fmap (T.pack . show) warnings

153+ for_ warnings $ putLog Warning . T.pack . show

131− case result of

154+ case condLibrary <$> result of

132− Right gpkg -> do

155+ Right (Just condLib) -> do

133− return $ do

134− (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg

156+ let (_, lib) = simplifyCondTree (const $ pure True) condLib

135− pure $ CabalPackageInfo

157+ pure $ CabalPackageInfo

136− { _cabalPackageInfo_packageRoot = takeDirectory cabalFp

158+ { _cabalPackageInfo_packageRoot = dir

137− , _cabalPackageInfo_sourceDirs =

159+ , _cabalPackageInfo_sourceDirs =

138− fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

160+ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

139− , _cabalPackageInfo_defaultExtensions =

161+ , _cabalPackageInfo_defaultExtensions =

140− defaultExtensions $ libBuildInfo lib

162+ defaultExtensions $ libBuildInfo lib

141− , _cabalPackageInfo_defaultLanguage =

163+ , _cabalPackageInfo_defaultLanguage =

142− defaultLanguage $ libBuildInfo lib

164+ defaultLanguage $ libBuildInfo lib

165+ , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib

143− }

166+ }

167+ Right Nothing -> throwError "Haskell package has no library component"

144− Left (_, errors) -> do

168+ Left (_, errors) ->

145− putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"

169+ throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)

146− mapM_ (putLog Error) $ fmap (T.pack . show) errors

147− return Nothing

148−

149−withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a

150−withUTF8FileContentsM fp f = do

151− c <- getCliConfig

152− liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS

153

170

154-- | Create ghci configuration to load the given packages

171-- | Create ghci configuration to load the given packages

155withGhciScript

172withGhciScript

156 :: MonadObelisk m

173 :: MonadObelisk m

157 => [FilePath] -- ^ List of packages to load into ghci

174 => [FilePath] -- ^ List of packages to load into ghci

158− -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporory .ghci

175+ -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci

159 -> m ()

176 -> m ()

160−withGhciScript pkgs f = do

177+withGhciScript dirs f = do

161− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \pkg -> do

178+ (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM dirs $ \dir -> do

162− flip fmap (parseCabalPackage pkg) $ \case

179+ flip fmap (parseCabalPackage dir) $ \case

163− Nothing -> Left pkg

180+ Nothing -> Left dir

164 Just packageInfo -> Right packageInfo

181 Just packageInfo -> Right packageInfo

165

182

166 when (null packageInfos) $

183 when (null packageInfos) $

167− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs

184+ failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " dirs

168 unless (null pkgDirErrs) $

185 unless (null pkgDirErrs) $

169 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

186 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

170

187

@@ -174,11 +191,16 @@ withGhciScript pkgs f = do

174 language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs

191 language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs

175 extensionsLine = if extensions == mempty

192 extensionsLine = if extensions == mempty

176 then ""

193 then ""

177− else ":set " <> intercalate " " ((("-X" <>) . prettyShow) <$> extensions)

194+ else ":set " <> unwords (("-X" <>) . prettyShow <$> extensions)

195+ ghcOptions = concat $ mapMaybe (\case (GHC, xs) -> Just xs; _ -> Nothing) $

196+ packageInfos >>= _cabalPackageInfo_compilerOptions

178− dotGhci = unlines $

197+ dotGhci = unlines

179 [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)

198 [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)

199+ , case ghcOptions of

200+ [] -> ""

201+ xs -> ":set " <> unwords xs

180 , extensionsLine

202 , extensionsLine

181− , ":set " <> intercalate " " (("-X" <>) . prettyShow <$> language)

203+ , ":set " <> unwords (("-X" <>) . prettyShow <$> language)

182 , ":load Backend Frontend"

204 , ":load Backend Frontend"

183 , "import Obelisk.Run"

205 , "import Obelisk.Run"

184 , "import qualified Frontend"

206 , "import qualified Frontend"

@@ -203,7 +225,7 @@ runGhciRepl

203 :: MonadObelisk m

225 :: MonadObelisk m

204 => FilePath -- ^ Path to .ghci

226 => FilePath -- ^ Path to .ghci

205 -> m ()

227 -> m ()

206−runGhciRepl dotGhci = inProjectShell "ghc" $ unwords $ "ghci" : ["-no-user-package-db", "-ghci-script", dotGhci]

228+runGhciRepl dotGhci = inProjectShell "ghc" $ "ghci " <> makeBaseGhciOptions dotGhci

207

229

208-- | Run ghcid

230-- | Run ghcid

209runGhcid

231runGhcid

@@ -211,17 +233,25 @@ runGhcid

211 => FilePath -- ^ Path to .ghci

233 => FilePath -- ^ Path to .ghci

212 -> Maybe String -- ^ Optional command to run at every reload

234 -> Maybe String -- ^ Optional command to run at every reload

213 -> m ()

235 -> m ()

214−runGhcid dotGhci mcmd = callCommand $ unwords $ "ghcid" : opts

236+runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts

215 where

237 where

216 opts =

238 opts =

217 [ "-W"

239 [ "-W"

218 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user

240 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user

219− , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints -no-user-package-db -ghci-script " <> dotGhci <> "' "

241+ , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints " <> makeBaseGhciOptions dotGhci <> "' "

220 , "--reload=config"

242 , "--reload=config"

221 , "--outputfile=ghcid-output.txt"

243 , "--outputfile=ghcid-output.txt"

222 ] <> testCmd

244 ] <> testCmd

223 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")

245 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")

224

246

247+makeBaseGhciOptions :: FilePath -> String

248+makeBaseGhciOptions dotGhci =

249+ unwords

250+ [ "-no-user-package-db"

251+ , "-package-env -"

252+ , "-ghci-script " <> dotGhci

253+ ]

254+

225getFreePort :: MonadIO m => m PortNumber

255getFreePort :: MonadIO m => m PortNumber

226getFreePort = liftIO $ withSocketsDo $ do

256getFreePort = liftIO $ withSocketsDo $ do

227 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")

257 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")

lib/command/src/Obelisk/Command/Thunk.hs+182−104

@@ -8,25 +8,30 @@

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 (..)

16− , GitHubSource (..)

17− , getThunkGitBranch

18− , getLatestRev

19− , updateThunkToLatest

20 , createThunk

21 , createThunk

21 , createThunkWithLatest

22 , createThunkWithLatest

23+ , getLatestRev

24+ , getThunkGitBranch

25+ , getThunkPtr

26+ , gitUriToText

22 , nixBuildAttrWithCache

27 , nixBuildAttrWithCache

23 , nixBuildThunkAttrWithCache

28 , nixBuildThunkAttrWithCache

24− , unpackThunk

25 , packThunk

29 , packThunk

30+ , parseGitUri

26 , readThunk

31 , readThunk

32+ , unpackThunk

27 , updateThunk

33 , updateThunk

28− , getThunkPtr

34+ , updateThunkToLatest

29− , parseGitUri

30 , uriThunkPtr

35 , uriThunkPtr

31 ) where

36 ) where

@@ -68,8 +73,7 @@ import System.FilePath

68import System.IO.Error

73import System.IO.Error

69import System.IO.Temp

74import System.IO.Temp

70import System.Posix (getSymbolicLinkStatus, modificationTime)

75import System.Posix (getSymbolicLinkStatus, modificationTime)

71−import System.Process (proc)

76+import qualified Text.URI as URI

72−import Text.URI

74import Obelisk.App (MonadObelisk)

78import Obelisk.App (MonadObelisk)

75import Obelisk.CliApp

79import Obelisk.CliApp

@@ -94,7 +98,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver

95-- | A specific revision of data; it may be available from multiple sources

99-- | A specific revision of data; it may be available from multiple sources

96data ThunkRev = ThunkRev

100data ThunkRev = ThunkRev

97− { _thunkRev_commit :: Ref

101+ { _thunkRev_commit :: Ref Ref.SHA1

98 , _thunkRev_nixSha256 :: NixSha256

102 , _thunkRev_nixSha256 :: NixSha256

99 }

103 }

100 deriving (Show, Eq, Ord)

104 deriving (Show, Eq, Ord)

@@ -111,37 +115,63 @@ data GitHubSource = GitHubSource

111 { _gitHubSource_owner :: Name Owner

115 { _gitHubSource_owner :: Name Owner

112 , _gitHubSource_repo :: Name Repo

116 , _gitHubSource_repo :: Name Repo

113 , _gitHubSource_branch :: Maybe (Name Branch)

117 , _gitHubSource_branch :: Maybe (Name Branch)

118+ , _gitHubSource_private :: Bool

114 }

119 }

115 deriving (Show, Eq, Ord)

120 deriving (Show, Eq, Ord)

116

121

122+newtype GitUri = GitUri URI.URI deriving (Eq, Ord, Show)

123+

124+gitUriToText :: GitUri -> Text

125+gitUriToText (GitUri uri)

126+ | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"

127+ , Just (_, path) <- URI.uriPath uri

128+ = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)

129+ | otherwise = URI.render uri

130+

117data GitSource = GitSource

131data GitSource = GitSource

118− { _gitSource_url :: URI

132+ { _gitSource_url :: GitUri

119 , _gitSource_branch :: Maybe (Name Branch)

133 , _gitSource_branch :: Maybe (Name Branch)

120 , _gitSource_fetchSubmodules :: Bool

134 , _gitSource_fetchSubmodules :: Bool

135+ , _gitSource_private :: Bool

121 }

136 }

122 deriving (Show, Eq, Ord)

137 deriving (Show, Eq, Ord)

123

138

139+newtype ThunkConfig = ThunkConfig

140+ { _thunkConfig_private :: Maybe Bool

141+ } deriving Show

142+

143+data ThunkUpdateConfig = ThunkUpdateConfig

144+ { _thunkUpdateConfig_branch :: Maybe String

145+ , _thunkUpdateConfig_config :: ThunkConfig

146+ } deriving Show

147+

148+data ThunkPackConfig = ThunkPackConfig

149+ { _thunkPackConfig_force :: Bool

150+ , _thunkPackConfig_config :: ThunkConfig

151+ } deriving Show

152+

124-- | Convert a GitHub source to a regular Git source. Assumes no submodules.

153-- | Convert a GitHub source to a regular Git source. Assumes no submodules.

125forgetGithub :: Bool -> GitHubSource -> GitSource

154forgetGithub :: Bool -> GitHubSource -> GitSource

126forgetGithub useSsh s = GitSource

155forgetGithub useSsh s = GitSource

127− { _gitSource_url = URI

156+ { _gitSource_url = GitUri $ URI.URI

128− { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"

157+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"

129− , uriAuthority = Right $ Authority

158+ , URI.uriAuthority = Right $ URI.Authority

130− { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing

159+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing

131 <$ guard useSsh

160 <$ guard useSsh

132− , authHost = fromRight' $ mkHost "github.com"

161+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

133− , authPort = Nothing

162+ , URI.authPort = Nothing

134 }

163 }

135− , uriPath = Just ( False

164+ , URI.uriPath = Just ( False

136− , fromRight' . mkPathPiece <$>

165+ , fromRight' . URI.mkPathPiece <$>

137 untagName (_gitHubSource_owner s)

166 untagName (_gitHubSource_owner s)

138 :| [ untagName (_gitHubSource_repo s) <> ".git" ]

167 :| [ untagName (_gitHubSource_repo s) <> ".git" ]

139 )

168 )

140− , uriQuery = []

169+ , URI.uriQuery = []

141− , uriFragment = Nothing

170+ , URI.uriFragment = Nothing

142 }

171 }

143 , _gitSource_branch = _gitHubSource_branch s

172 , _gitSource_branch = _gitHubSource_branch s

144 , _gitSource_fetchSubmodules = False

173 , _gitSource_fetchSubmodules = False

174+ , _gitSource_private = _gitHubSource_private s

145 }

175 }

146

176

147getThunkGitBranch :: ThunkPtr -> Maybe Text

177getThunkGitBranch :: ThunkPtr -> Maybe Text

@@ -149,26 +179,26 @@ getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of

149 ThunkSource_GitHub s -> _gitHubSource_branch s

179 ThunkSource_GitHub s -> _gitHubSource_branch s

150 ThunkSource_Git s -> _gitSource_branch s

180 ThunkSource_Git s -> _gitSource_branch s

151

181

152−commitNameToRef :: Name Commit -> Ref

182+commitNameToRef :: Name Commit -> Ref Ref.SHA1

153commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

183commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

154

184

155-- TODO: Use spinner here.

185-- TODO: Use spinner here.

156getNixSha256ForUriUnpacked

186getNixSha256ForUriUnpacked

157 :: MonadObelisk m

187 :: MonadObelisk m

158− => URI

188+ => GitUri

159 -> m NixSha256

189 -> m NixSha256

160getNixSha256ForUriUnpacked uri =

190getNixSha256ForUriUnpacked uri =

161− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do

191+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do

162 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $

192 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $

163− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]

193+ proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]

164 pure hash

194 pure hash

165

195

166−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256

196+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256

167nixPrefetchGit uri rev fetchSubmodules =

197nixPrefetchGit uri rev fetchSubmodules =

168− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do

198+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do

169 out <- readProcessAndLogStderr Debug $

199 out <- readProcessAndLogStderr Debug $

170 proc "nix-prefetch-git" $ filter (/="")

200 proc "nix-prefetch-git" $ filter (/="")

171− [ "--url", T.unpack $ render uri

201+ [ "--url", T.unpack $ gitUriToText uri

172 , "--rev", T.unpack rev

202 , "--rev", T.unpack rev

173 , if fetchSubmodules then "--fetch-submodules" else ""

203 , if fetchSubmodules then "--fetch-submodules" else ""

174 , "--quiet"

204 , "--quiet"

@@ -286,10 +316,12 @@ parseGitHubSource v = do

286 owner <- v Aeson..: "owner"

316 owner <- v Aeson..: "owner"

287 repo <- v Aeson..: "repo"

317 repo <- v Aeson..: "repo"

288 branch <- v Aeson..:! "branch"

318 branch <- v Aeson..:! "branch"

319+ private <- v Aeson..:? "private"

289 pure $ GitHubSource

320 pure $ GitHubSource

290 { _gitHubSource_owner = owner

321 { _gitHubSource_owner = owner

291 , _gitHubSource_repo = repo

322 , _gitHubSource_repo = repo

292 , _gitHubSource_branch = branch

323 , _gitHubSource_branch = branch

324+ , _gitHubSource_private = fromMaybe False private

293 }

325 }

294

326

295parseGitSource :: Aeson.Object -> Aeson.Parser GitSource

327parseGitSource :: Aeson.Object -> Aeson.Parser GitSource

@@ -297,10 +329,12 @@ parseGitSource v = do

297 Just url <- parseGitUri <$> v Aeson..: "url"

329 Just url <- parseGitUri <$> v Aeson..: "url"

298 branch <- v Aeson..:! "branch"

330 branch <- v Aeson..:! "branch"

299 fetchSubmodules <- v Aeson..:! "fetchSubmodules"

331 fetchSubmodules <- v Aeson..:! "fetchSubmodules"

332+ private <- v Aeson..:? "private"

300 pure $ GitSource

333 pure $ GitSource

301 { _gitSource_url = url

334 { _gitSource_url = url

302 , _gitSource_branch = branch

335 , _gitSource_branch = branch

303 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules

336 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules

337+ , _gitSource_private = fromMaybe False private

304 }

338 }

305

339

306overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()

340overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()

@@ -327,13 +361,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

327 , ("branch" .=) <$> _gitHubSource_branch s

361 , ("branch" .=) <$> _gitHubSource_branch s

328 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

362 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

329 , Just $ "sha256" .= _thunkRev_nixSha256 rev

363 , Just $ "sha256" .= _thunkRev_nixSha256 rev

364+ , Just $ "private" .= _gitHubSource_private s

330 ]

365 ]

331 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes

366 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes

332− [ Just $ "url" .= render (_gitSource_url s)

367+ [ Just $ "url" .= gitUriToText (_gitSource_url s)

333 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

368 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

334 , ("branch" .=) <$> _gitSource_branch s

369 , ("branch" .=) <$> _gitSource_branch s

335 , Just $ "sha256" .= _thunkRev_nixSha256 rev

370 , Just $ "sha256" .= _thunkRev_nixSha256 rev

336 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

371 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

372+ , Just $ "private" .= _gitSource_private s

337 ]

373 ]

338 where

374 where

339 githubCfg = defConfig

375 githubCfg = defConfig

@@ -354,6 +390,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

354 [ "url"

390 [ "url"

355 , "rev"

391 , "rev"

356 , "sha256"

392 , "sha256"

393+ , "private"

357 , "fetchSubmodules"

394 , "fetchSubmodules"

358 ] <> compare

395 ] <> compare

359 , confTrailingNewline = True

396 , confTrailingNewline = True

@@ -377,8 +414,8 @@ createThunkWithLatest target s = do

377 , _thunkPtr_rev = rev

414 , _thunkPtr_rev = rev

378 }

415 }

379

416

380−updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()

417+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

418+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

419 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

420 -- check to see if thunk should be updated to a specific branch or just update it's current branch

384 case mBranch of

421 case mBranch of

@@ -390,7 +427,7 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t

390 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"

427 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"

391 let src = _thunkPtr_source ptr

428 let src = _thunkPtr_source ptr

392 rev <- getLatestRev src

429 rev <- getLatestRev src

393− overwriteThunk overwrite $ ThunkPtr

430+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr

394 { _thunkPtr_source = src

431 { _thunkPtr_source = src

395 , _thunkPtr_rev = rev

432 , _thunkPtr_rev = rev

396 }

433 }

@@ -398,24 +435,25 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t

398 Left err -> failWith $ T.pack $ "thunk update: " <> show err

435 Left err -> failWith $ T.pack $ "thunk update: " <> show err

399 Right c -> case c of

436 Right c -> case c of

400 ThunkData_Packed t -> case _thunkPtr_source t of

437 ThunkData_Packed t -> case _thunkPtr_source t of

401− ThunkSource_Git tsg -> setThunk target tsg branch

438+ ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch

402 ThunkSource_GitHub tsgh -> do

439 ThunkSource_GitHub tsgh -> do

403 let tsg = forgetGithub False tsgh

440 let tsg = forgetGithub False tsgh

404− setThunk target tsg branch

441+ 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."

442+ 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

443

407−setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()

444+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()

408−setThunk target gs branch = do

445+setThunk thunkConfig target gs branch = do

409 newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing

446 newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing

410 overwriteThunk target newThunkPtr

447 overwriteThunk target newThunkPtr

411− updateThunkToLatest target Nothing

448+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target

412

449

413-- | All recognized github standalone loaders, ordered from newest to oldest.

450-- | 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.

451-- This tool will only ever produce the newest one when it writes a thunk.

415gitHubStandaloneLoaders :: NonEmpty Text

452gitHubStandaloneLoaders :: NonEmpty Text

416gitHubStandaloneLoaders =

453gitHubStandaloneLoaders =

417− gitHubStandaloneLoaderV2 :|

454+ gitHubStandaloneLoaderV4 :|

418 [ gitHubStandaloneLoaderV3

455 [ gitHubStandaloneLoaderV3

456+ , gitHubStandaloneLoaderV2

419 , gitHubStandaloneLoaderV1

457 , gitHubStandaloneLoaderV1

420 ]

458 ]

421

459

@@ -455,10 +493,23 @@ gitHubStandaloneLoaderV3 = T.unlines

455 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

493 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

456 ]

494 ]

457

495

496+gitHubStandaloneLoaderV4 :: Text

497+gitHubStandaloneLoaderV4 = T.unlines

498+ [ "# DO NOT HAND-EDIT THIS FILE"

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

500+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"

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

502+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"

503+ , " inherit owner repo rev sha256 fetchSubmodules private;"

504+ , " };"

505+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

506+ ]

507+

458plainGitStandaloneLoaders :: NonEmpty Text

508plainGitStandaloneLoaders :: NonEmpty Text

459plainGitStandaloneLoaders =

509plainGitStandaloneLoaders =

460− plainGitStandaloneLoaderV1 :|

510+ plainGitStandaloneLoaderV3 :|

511+ [ plainGitStandaloneLoaderV1

461− [ plainGitStandaloneLoaderV2

512+ , plainGitStandaloneLoaderV2

462 ]

513 ]

463

514

464plainGitStandaloneLoaderV1 :: Text

515plainGitStandaloneLoaderV1 :: Text

@@ -479,6 +530,22 @@ plainGitStandaloneLoaderV2 = T.unlines

479 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

530 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

480 ]

531 ]

481

532

533+plainGitStandaloneLoaderV3 :: Text

534+plainGitStandaloneLoaderV3 = T.unlines

535+ [ "# DO NOT HAND-EDIT THIS FILE"

536+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

537+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

538+ , " if firstChar == \"/\" then /. + url"

539+ , " else if firstChar == \".\" then ./. + url"

540+ , " else url;"

541+ , " in if !fetchSubmodules && private then builtins.fetchGit {"

542+ , " url = realUrl; inherit rev;"

543+ , " } else (import <nixpkgs> {}).fetchgit {"

544+ , " url = realUrl; inherit rev sha256;"

545+ , " };"

546+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

547+ ]

548+

482thunkFileNames :: [FilePath]

549thunkFileNames :: [FilePath]

483thunkFileNames = ["default.nix", "github.json", "git.json"]

550thunkFileNames = ["default.nix", "github.json", "git.json"]

484

551

@@ -520,7 +587,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do

520 Just c -> return c

587 Just c -> return c

521 Nothing -> do

588 Nothing -> do

522 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

589 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

523− _ <- nixCmd $ NixCmd_Build$ def

590+ _ <- nixCmd $ NixCmd_Build $ def

524 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

591 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

525 Lens.& nixCmdConfig_target Lens..~ Target

592 Lens.& nixCmdConfig_target Lens..~ Target

526 { _target_path = Just thunkDir

593 { _target_path = Just thunkDir

@@ -568,13 +635,13 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

568 Right (ThunkData_Packed _) -> do

635 Right (ThunkData_Packed _) -> do

569 let tmpThunk = tmpDir </> "thunk"

636 let tmpThunk = tmpDir </> "thunk"

570 callProcessAndLogOutput (Notice, Error) $

637 callProcessAndLogOutput (Notice, Error) $

571− proc "cp" ["-r", "-T", thunkDir, tmpThunk]

638+ proc cp ["-r", "-T", thunkDir, tmpThunk]

572 return tmpThunk

639 return tmpThunk

573− Right _ -> failWith $ "Thunk is not packed"

640+ Right _ -> failWith "Thunk is not packed"

574 updateThunkFromTmp p' = do

641 updateThunkFromTmp p' = do

575− _ <- packThunk' True False p'

642+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'

576 callProcessAndLogOutput (Notice, Error) $

643 callProcessAndLogOutput (Notice, Error) $

577− proc "cp" ["-r", "-T", p', p]

644+ proc cp ["-r", "-T", p', p]

578

645

579finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)

646finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)

580finalMsg noTrail s = if noTrail then Nothing else Just s

647finalMsg noTrail s = if noTrail then Nothing else Just s

@@ -606,7 +673,7 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with

606 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo

673 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo

607 git $ [ "clone" ]

674 git $ [ "clone" ]

608 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))

675 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))

609− ++ [ T.unpack $ render $ _gitSource_url s ]

676+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]

610 ++ do branch <- maybeToList $ _gitSource_branch s

677 ++ do branch <- maybeToList $ _gitSource_branch s

611 [ "--branch", T.unpack $ untagName branch ]

678 [ "--branch", T.unpack $ untagName branch ]

612 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

679 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

@@ -615,31 +682,39 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with

615

682

616 liftIO $ createDirectory obGitDir

683 liftIO $ createDirectory obGitDir

617 callProcessAndLogOutput (Notice, Error) $

684 callProcessAndLogOutput (Notice, Error) $

618− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]

685+ proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]

619 callProcessAndLogOutput (Notice, Error) $

686 callProcessAndLogOutput (Notice, Error) $

620 proc "rm" ["-r", thunkDir]

687 proc "rm" ["-r", thunkDir]

621 callProcessAndLogOutput (Notice, Error) $

688 callProcessAndLogOutput (Notice, Error) $

622 proc "mv" ["-T", tmpRepo, thunkDir]

689 proc "mv" ["-T", tmpRepo, thunkDir]

623

690

624--TODO: add a rollback mode to pack to the original thunk

691--TODO: add a rollback mode to pack to the original thunk

625−packThunk :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr

692+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr

626packThunk = packThunk' False

693packThunk = packThunk' False

627

694

628−packThunk' :: MonadObelisk m => Bool -> Bool -> FilePath -> m ThunkPtr

695+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

696+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

697 Left err -> failWith $ T.pack $ "thunk pack: " <> show err

631 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

698 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

632 Right (ThunkData_Checkout _) -> do

699 Right (ThunkData_Checkout _) -> do

633 withSpinner' ("Packing thunk " <> T.pack thunkDir)

700 withSpinner' ("Packing thunk " <> T.pack thunkDir)

634 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do

701 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do

635− thunkPtr <- getThunkPtr (not force) thunkDir

702+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir

636 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]

703 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]

637 liftIO $ createThunk thunkDir thunkPtr

704 liftIO $ createThunk thunkDir thunkPtr

638 pure thunkPtr

705 pure thunkPtr

639

706

707+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr

708+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of

709+ Nothing -> ptr

710+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of

711+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }

712+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }

713+ }

714+

640getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr

715getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr

641getThunkPtr checkClean thunkDir = do

716getThunkPtr checkClean thunkDir = do

642− when checkClean $ ensureCleanGitRepo thunkDir True $

717+ when checkClean $ ensureCleanGitRepo thunkDir True

643 "thunk pack: thunk checkout contains unsaved modifications"

718 "thunk pack: thunk checkout contains unsaved modifications"

644

719

645 -- Check whether there are any stashes

720 -- Check whether there are any stashes

@@ -661,7 +736,7 @@ getThunkPtr checkClean thunkDir = do

661 <$> T.lines

736 <$> T.lines

662 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]

737 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]

663 case b of

738 case b of

664− (Just "HEAD") -> failWith $ T.unlines $

739+ (Just "HEAD") -> failWith $ T.unlines

665 [ "thunk pack: You are in 'detached HEAD' state."

740 [ "thunk pack: You are in 'detached HEAD' state."

666 , "If you want to pack at the current ref \

741 , "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."

742 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."

@@ -733,7 +808,7 @@ getThunkPtr checkClean thunkDir = do

733 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"

808 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"

734 , ""

809 , ""

735 ] ++

810 ] ++

736− (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat

811+ 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]) ++

812 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++

738 [ ""

813 [ ""

739 , "Please push these upstream and try again. (Or just fetch, if they are somehow \

814 , "Please push these upstream and try again. (Or just fetch, if they are somehow \

@@ -741,7 +816,7 @@ getThunkPtr checkClean thunkDir = do

741 ]

816 ]

742

817

743 -- We assume it's safe to pack the thunk at this point

818 -- 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."

819+ putLog Informational "All changes safe in git remotes. OK to pack thunk."

745

820

746 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

821 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

747

822

@@ -773,7 +848,7 @@ getLatestRev os = do

773-- performance. If that doesn't work (e.g. authentication issue), we fall back

848-- 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

849-- on just doing things the normal way for git repos in general, and save it as

775-- a regular git thunk.

850-- a regular git thunk.

776−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr

851+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Text -> Maybe Text -> m ThunkPtr

777uriThunkPtr uri mbranch mcommit = do

852uriThunkPtr uri mbranch mcommit = do

778 commit <- case mcommit of

853 commit <- case mcommit of

779 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd

854 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd

@@ -784,7 +859,7 @@ uriThunkPtr uri mbranch mcommit = do

784 case rev of

859 case rev of

785 Right r -> pure (ThunkSource_GitHub s, r)

860 Right r -> pure (ThunkSource_GitHub s, r)

786 Left e -> do

861 Left e -> do

787− putLog Warning $ "\

862+ putLog Warning "\

788\Failed to fetch archive from GitHub. This is probably a private repo. \

863\Failed to fetch archive from GitHub. This is probably a private repo. \

789\Falling back on normal fetchgit. Original failure:"

864\Falling back on normal fetchgit. Original failure:"

790 errorToWarning e

865 errorToWarning e

@@ -801,33 +876,33 @@ uriThunkPtr uri mbranch mcommit = do

801-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with

876-- 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

877-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method

803-- should be employed, and so we respect that.

878-- should be employed, and so we respect that.

804−uriToThunkSource :: URI -> Maybe Text -> ThunkSource

879+uriToThunkSource :: GitUri -> Maybe Text -> ThunkSource

805−uriToThunkSource u

880+uriToThunkSource (GitUri u)

806− | Right uriAuth <- uriAuthority u

881+ | Right uriAuth <- URI.uriAuthority u

807− , Just scheme <- unRText <$> uriScheme u

882+ , Just scheme <- URI.unRText <$> URI.uriScheme u

808 , case scheme of

883 , case scheme of

809− "ssh" -> uriAuth == Authority

884+ "ssh" -> uriAuth == URI.Authority

810− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing

885+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing

811− , authHost = fromRight' $ mkHost "github.com"

886+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

812− , authPort = Nothing

887+ , URI.authPort = Nothing

813 }

888 }

814 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"

889 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"

815− && unRText (authHost uriAuth) == "github.com"

890+ && URI.unRText (URI.authHost uriAuth) == "github.com"

816− , Just (_, owner :| [repoish]) <- uriPath u

891+ , Just (_, owner :| [repoish]) <- URI.uriPath u

817 = \mbranch -> ThunkSource_GitHub $ GitHubSource

892 = \mbranch -> ThunkSource_GitHub $ GitHubSource

818− { _gitHubSource_owner = N $ unRText owner

893+ { _gitHubSource_owner = N $ URI.unRText owner

819 , _gitHubSource_repo = N $ let

894 , _gitHubSource_repo = N $ let

820− repoish' = unRText repoish

895+ repoish' = URI.unRText repoish

821− in case T.stripSuffix ".git" repoish' of

896+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'

822− Just repo -> repo

823− Nothing -> repoish'

824 , _gitHubSource_branch = N <$> mbranch

897 , _gitHubSource_branch = N <$> mbranch

898+ , _gitHubSource_private = False -- TODO: Can we try something to infer this?

825 }

899 }

826

900

827 | otherwise = \mbranch -> ThunkSource_Git $ GitSource

901 | otherwise = \mbranch -> ThunkSource_Git $ GitSource

828− { _gitSource_url = u

902+ { _gitSource_url = GitUri u

829 , _gitSource_branch = N <$> mbranch

903 , _gitSource_branch = N <$> mbranch

830 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?

904 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?

905+ , _gitSource_private = False -- TODO: Can we try something to infer this?

831 }

906 }

832

907

833-- Funny signature indicates no effects depend on the optional branch name.

908-- Funny signature indicates no effects depend on the optional branch name.

@@ -840,19 +915,19 @@ githubThunkRev

840githubThunkRev s commit = do

915githubThunkRev s commit = do

841 owner <- forcePP $ _gitHubSource_owner s

916 owner <- forcePP $ _gitHubSource_owner s

842 repo <- forcePP $ _gitHubSource_repo s

917 repo <- forcePP $ _gitHubSource_repo s

843− revTarball <- mkPathPiece $ commit <> ".tar.gz"

918+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"

844− let archiveUri = URI

919+ let archiveUri = GitUri $ URI.URI

845− { uriScheme = Just $ fromRight' $ mkScheme "https"

920+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"

846− , uriAuthority = Right $ Authority

921+ , URI.uriAuthority = Right $ URI.Authority

847− { authUserInfo = Nothing

922+ { URI.authUserInfo = Nothing

848− , authHost = fromRight' $ mkHost "github.com"

923+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

849− , authPort = Nothing

924+ , URI.authPort = Nothing

850 }

925 }

851− , uriPath = Just ( False

926+ , URI.uriPath = Just ( False

852− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]

927+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]

853 )

928 )

854− , uriQuery = []

929+ , URI.uriQuery = []

855− , uriFragment = Nothing

930+ , URI.uriFragment = Nothing

856 }

931 }

857 hash <- getNixSha256ForUriUnpacked archiveUri

932 hash <- getNixSha256ForUriUnpacked archiveUri

858 putLog Debug $ "Nix sha256 is " <> hash

933 putLog Debug $ "Nix sha256 is " <> hash

@@ -861,8 +936,8 @@ githubThunkRev s commit = do

861 , _thunkRev_nixSha256 = hash

936 , _thunkRev_nixSha256 = hash

862 }

937 }

863 where

938 where

864− forcePP :: Name entity -> m (RText 'PathPiece)

939+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)

865− forcePP = mkPathPiece . untagName

940+ forcePP = URI.mkPathPiece . untagName

866

941

867gitThunkRev

942gitThunkRev

868 :: MonadObelisk m

943 :: MonadObelisk m

@@ -871,11 +946,11 @@ gitThunkRev

871 -> m ThunkRev

946 -> m ThunkRev

872gitThunkRev s commit = do

947gitThunkRev s commit = do

873 let u = _gitSource_url s

948 let u = _gitSource_url s

874− protocols = ["https", "ssh", "git"]

949+ protocols = ["file", "https", "ssh", "git"]

875− Just scheme <- pure $ unRText <$> uriScheme u

950+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u

876 unless (T.toLower scheme `elem` protocols) $

951 unless (T.toLower scheme `elem` protocols) $

877 failWith $ "obelisk currently only supports "

952 failWith $ "obelisk currently only supports "

878− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"

953+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"

879 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s

954 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s

880 putLog Informational $ "Nix sha256 is " <> hash

955 putLog Informational $ "Nix sha256 is " <> hash

881 pure $ ThunkRev

956 pure $ ThunkRev

@@ -889,10 +964,10 @@ gitThunkRev s commit = do

889-- If the branch name is passed in, it is returned exactly as-is. If it is not

964-- 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.

965-- passed it, the default branch of the repo is used instead.

891gitGetCommitBranch

966gitGetCommitBranch

892− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)

967+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)

893gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do

968gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do

894 (_, bothMaps) <- gitLsRemote

969 (_, bothMaps) <- gitLsRemote

895− (T.unpack $ render uri)

970+ (T.unpack $ gitUriToText uri)

896 (GitRef_Branch <$> mbranch)

971 (GitRef_Branch <$> mbranch)

897 Nothing

972 Nothing

898 branch <- case mbranch of

973 branch <- case mbranch of

@@ -908,18 +983,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "

908 pure (branch, commit)

983 pure (branch, commit)

909 where

984 where

910 rethrowE = either failWith pure

985 rethrowE = either failWith pure

911− uriMsg = render uri

986+ uriMsg = gitUriToText uri

987+

988+parseGitUri :: Text -> Maybe GitUri

989+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)

912

990

913−parseGitUri :: Text -> Maybe URI

991+parseFileURI :: Text -> Maybe URI.URI

914−parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x

992+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing

915

993

916−parseAbsoluteURI :: Text -> Maybe URI

994+parseAbsoluteURI :: Text -> Maybe URI.URI

917parseAbsoluteURI uri = do

995parseAbsoluteURI uri = do

918− parsedUri <- mkURI uri

996+ parsedUri <- URI.mkURI uri

919− guard $ isPathAbsolute parsedUri

997+ guard $ URI.isPathAbsolute parsedUri

920− pure $ parsedUri

998+ pure parsedUri

921

999

922−parseSshShorthand :: Text -> Maybe URI

1000+parseSshShorthand :: Text -> Maybe URI.URI

923parseSshShorthand uri = do

1001parseSshShorthand uri = do

924 -- This is what git does to check that the remote

1002 -- This is what git does to check that the remote

925 -- is not a local file path when parsing shorthand.

1003 -- is not a local file path when parsing shorthand.

@@ -932,4 +1010,4 @@ parseSshShorthand uri = do

932 -- This check is used to disambiguate a filepath containing a colon from shorthand

1010 -- This check is used to disambiguate a filepath containing a colon from shorthand

933 guard $ isNothing (T.findIndex (=='/') authAndHostname)

1011 guard $ isNothing (T.findIndex (=='/') authAndHostname)

934 && not (T.null colonAndPath)

1012 && not (T.null colonAndPath)

935− mkURI properUri

1013+ URI.mkURI properUri

lib/command/src/Obelisk/Command/Utils.hs+28−14

@@ -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)

@@ -23,7 +24,7 @@ import Data.Void (Void)

23import System.Directory (canonicalizePath)

24import System.Directory (canonicalizePath)

24import System.Environment (getExecutablePath)

25import System.Environment (getExecutablePath)

25import System.Exit (ExitCode)

26import System.Exit (ExitCode)

26−import qualified System.Process as P

27+import System.Which (staticWhich)

27import Text.Megaparsec as MP

28import Text.Megaparsec as MP

28import Text.Megaparsec.Char as MP

29import Text.Megaparsec.Char as MP

@@ -33,6 +34,9 @@ import Obelisk.CliApp

33getObeliskExe :: IO FilePath

34getObeliskExe :: IO FilePath

34getObeliskExe = getExecutablePath >>= canonicalizePath

35getObeliskExe = getExecutablePath >>= canonicalizePath

37+cp :: FilePath

38+cp = $(staticWhich "cp")

39+

36-- Check whether the working directory is clean

40-- Check whether the working directory is clean

37checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool

41checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool

38checkGitCleanStatus repo withIgnored = do

42checkGitCleanStatus repo withIgnored = do

@@ -61,20 +65,30 @@ initGit repo = do

61 git ["add", "."]

65 git ["add", "."]

62 git ["commit", "-m", "Initial commit."]

66 git ["commit", "-m", "Initial commit."]

64−gitProcNoRepo :: [String] -> P.CreateProcess

68+gitProcNoRepo :: [String] -> ProcessSpec

65−gitProcNoRepo = P.proc "git"

69+gitProcNoRepo args = setEnvOverride (M.singleton "GIT_TERMINAL_PROMPT" "0" <>) $ proc "git" args

67−gitProc :: FilePath -> [String] -> P.CreateProcess

71+gitProc :: FilePath -> [String] -> ProcessSpec

68gitProc repo = gitProcNoRepo . runGitInDir

72gitProc repo = gitProcNoRepo . runGitInDir

69 where

73 where

70 runGitInDir args' = case filter (not . null) args' of

74 runGitInDir args' = case filter (not . null) args' of

71 args@("clone":_) -> args <> [repo]

75 args@("clone":_) -> args <> [repo]

72 args -> ["-C", repo] <> args

76 args -> ["-C", repo] <> args

78+isolateGitProc :: ProcessSpec -> ProcessSpec

79+isolateGitProc = setEnvOverride (overrides <>)

80+ where

81+ overrides = M.fromList

82+ [ ("HOME", "/dev/null")

83+ , ("GIT_CONFIG_NOSYSTEM", "1")

84+ , ("GIT_TERMINAL_PROMPT", "0")

85+ , ("GIT_SSH_COMMAND", "ssh -o PreferredAuthentications=password -o PubkeyAuthentication=no -o GSSAPIAuthentication=no")

86+ ]

87+

74−-- | Recursively copy a directory using `cp -a`

88+-- | Recursively copy a directory using `cp -a` -- TODO: Should use -rT instead of -a

75−copyDir :: FilePath -> FilePath -> P.CreateProcess

89+copyDir :: FilePath -> FilePath -> ProcessSpec

76copyDir src dest =

90copyDir src dest =

77− (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }

91+ setCwd (Just src) $ proc cp ["-a", ".", dest] -- TODO: This will break if dest is relative since we change cwd

79readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

93readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

80readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

94readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

@@ -87,15 +101,15 @@ processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

87 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

101 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

102

89-- | A simpler wrapper for CliApp's most used process function with sensible defaults.

103-- | A simpler wrapper for CliApp's most used process function with sensible defaults.

90−runProc :: MonadObelisk m => P.CreateProcess -> m ()

104+runProc :: MonadObelisk m => ProcessSpec -> m ()

91runProc = callProcessAndLogOutput (Notice, Error)

105runProc = callProcessAndLogOutput (Notice, Error)

106

93-- | Like runProc, but all output goes to Debug logging level

107-- | Like runProc, but all output goes to Debug logging level

94−runProcSilently :: MonadObelisk m => P.CreateProcess -> m ()

108+runProcSilently :: MonadObelisk m => ProcessSpec -> m ()

95runProcSilently = callProcessAndLogOutput (Debug, Debug)

109runProcSilently = callProcessAndLogOutput (Debug, Debug)

110

97-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.

111-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.

98−readProc :: MonadObelisk m => P.CreateProcess -> m Text

112+readProc :: MonadObelisk m => ProcessSpec -> m Text

99readProc = readProcessAndLogOutput (Debug, Error)

113readProc = readProcessAndLogOutput (Debug, Error)

100

114

101tshow :: Show a => a -> Text

115tshow :: Show a => a -> Text

@@ -129,13 +143,13 @@ gitLsRemote repository mRef mBranch = do

129 (exitCode, out, _err) <- case mBranch of

143 (exitCode, out, _err) <- case mBranch of

130 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

144 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

131 ["ls-remote", "--exit-code", "--symref", repository]

145 ["ls-remote", "--exit-code", "--symref", repository]

132− ++ (maybeToList $ T.unpack . showGitRef <$> mRef)

146+ ++ maybeToList (T.unpack . showGitRef <$> mRef)

133− Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo $

147+ Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo

134 ["ls-remote", "--exit-code", repository, branchName]

148 ["ls-remote", "--exit-code", repository, branchName]

135 let t = T.pack out

149 let t = T.pack out

136 maps <- case MP.runParser parseLsRemote "" t of

150 maps <- case MP.runParser parseLsRemote "" t of

137− Left err -> failWith $ T.pack $ MP.parseErrorPretty' t err

151+ Left err -> failWith $ T.pack $ MP.errorBundlePretty err

138− Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table

152+ Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers table

139 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

153 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

140 pure (exitCode, maps)

154 pure (exitCode, maps)

141

155

lib/command/src/Obelisk/Command/VmBuilder.hs+2−2

@@ -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

@@ -156,7 +155,8 @@ testLinuxBuild stateDir

156 | System.Info.os == "linux" = failWith "Using the docker builder is not necessary on linux."

155 | System.Info.os == "linux" = failWith "Using the docker builder is not necessary on linux."

157 | otherwise = do

156 | otherwise = do

158 (exitCode, _stdout, stderr) <- readCreateProcessWithExitCode $ proc "nix-build"

157 (exitCode, _stdout, stderr) <- readCreateProcessWithExitCode $ proc "nix-build"

158+ [ "--no-out-link"

159− [ "-E", "(import <nixpkgs> { system = \"x86_64-linux\"; }).writeText \"test\" builtins.currentTime"

159+ , "-E", "(import <nixpkgs> { system = \"x86_64-linux\"; }).writeText \"test\" builtins.currentTime"

160 , "--builders", nixBuildersArgString stateDir

161 ]

162 unless (exitCode == ExitSuccess) $ do

lib/executable-config/default.nix+1−1

@@ -20,7 +20,7 @@ let injectConfig = config: assets: nixpkgs.runCommand "inject-config" {} (''

20 '');

21in with nixpkgs.haskell.lib; {

22 haskellOverlay = self: super: {

23− obelisk-executable-config-lookup = self.callPackage (filterGitSource ./lookup) {};

23+ obelisk-executable-config-lookup = self.callCabal2nix "obelisk-executable-config-lookup" (filterGitSource ./lookup) {};

24 };

25 platforms = {

26 android = {

lib/executable-config/lookup/default.nixdeleted−26

@@ -1,26 +0,0 @@

1−{ hostPlatform, ghc

2−, mkDerivation, base, base64-bytestring, bytestring, filepath, stdenv, text, transformers

3−, transformers-base, ref-tf, primitive, monad-control, reflex, reflex-dom

4−, jsaddle

5−, android-activity ? null, jsaddle-wkwebview ? null, ghcjs-dom ? null

6−}:

7−let isAndroid = hostPlatform.libc == "bionic";

8− isIOS = hostPlatform.isDarwin && hostPlatform.isAarch64;

9− isGhcjs = ghc.isGhcjs or false;

10−in mkDerivation {

11− pname = "obelisk-executable-config-lookup";

12− version = "0.1";

13− src = ./.;

14− libraryHaskellDepends = [

15− base bytestring filepath text transformers transformers-base ref-tf primitive monad-control reflex reflex-dom jsaddle

16− ] ++ (if isAndroid then [

17− android-activity

18− ] else if isIOS then [

19− jsaddle-wkwebview

20− ] else if isGhcjs then [

21− ghcjs-dom

22− ] else [

23− ]);

24− license = stdenv.lib.licenses.bsd3;

25−}

26−

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-ghcjs/Obelisk/ExecutableConfig/Lookup.hs+17−8

@@ -15,28 +15,37 @@ import GHCJS.DOM.Document (getHead)

15import GHCJS.DOM.DOMStringMap (get)

16import GHCJS.DOM.Element (getInnerHTML)

17import GHCJS.DOM.HTMLElement (HTMLElement(HTMLElement), getDataset)

18−import GHCJS.DOM.NodeList (item, getLength)

18+import GHCJS.DOM.NodeList (IsNodeList, item, getLength)

19import GHCJS.DOM.ParentNode (querySelectorAll)

20−import GHCJS.DOM.Types (Node(Node), castTo)

20+import GHCJS.DOM.Types (MonadJSM, Node(Node), castTo)

22getConfigs :: IO (Map Text ByteString)

23getConfigs = do

24 Just doc <- currentDocument

25 Just hd <- getHead doc

26− nodes <- collToList =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

26+ nodes <- nodeListNodes =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

27 fmap Map.fromList $ for nodes $ \node -> do

28 e <- castTo HTMLElement node >>= \case

29 Nothing -> error "Found node with data attribute obelisk-executable-config-inject-key that is not an HTMLElement."

30 Just htmlE -> return htmlE

31 dataset <- getDataset e

32 (,)

33− <$> get dataset ("obelisk-executable-config-inject-key" :: Text)

33+ -- the key is camelCased: https://html.spec.whatwg.org/multipage/dom.html#dom-dataset

34+ <$> get dataset ("obeliskExecutableConfigInjectKey" :: Text)

34 <*> (fmap decodeOrFail (getInnerHTML e))

35 <*> (fmap decodeOrFail (getInnerHTML e))

35 where

36 where

36− collToList es = do

37− len <- getLength es

38− list <- traverse (item es) [0..len-1]

39− pure $ catMaybes list

40 decodeOrFail x = case B64.decode (T.encodeUtf8 x) of

37 decodeOrFail x = case B64.decode (T.encodeUtf8 x) of

41 Left e -> error ("Obelisk.ExecutableConfig.Lookup.getConfigs: error when decoding base64: " ++ e)

38 Left e -> error ("Obelisk.ExecutableConfig.Lookup.getConfigs: error when decoding base64: " ++ e)

42 Right x' -> x'

39 Right x' -> x'

40+

41+-- | Collect all nodes in the node list.

42+--

43+-- TODO: this and the version in obelisk-frontend should be

44+-- upstreamed to jsaddle.

45+nodeListNodes :: (IsNodeList l, MonadJSM m) => l -> m [Node]

46+nodeListNodes es = do

47+ len <- getLength es

48+ -- Warning! len is unsigned. If the NodeList is empty, we must avoid

49+ -- accidentally traversing over [0..maxBound::Word]

50+ nodes <- traverse (item es) $ if len == 0 then [] else [0..len-1]

51+ pure $ catMaybes nodes

lib/executable-config/lookup/src/Obelisk/Configs.hs+5

@@ -15,6 +15,7 @@ module Obelisk.Configs

15 , ConfigsT

16 , runConfigsT

17 , mapConfigsT

18+ , getTextConfig

18 ) where

19 ) where

20import Control.Applicative

21import Control.Applicative

@@ -31,6 +32,7 @@ import Data.ByteString (ByteString)

31import Data.Map (Map)

32import Data.Map (Map)

32import qualified Data.Map as Map

33import qualified Data.Map as Map

33import Data.Text (Text)

34import Data.Text (Text)

35+import qualified Data.Text.Encoding as T

34import Reflex

36import Reflex

35import Reflex.Host.Class

37import Reflex.Host.Class

36import Reflex.Dom

38import Reflex.Dom

@@ -50,6 +52,9 @@ class Monad m => HasConfigs m where

50instance Monad m => HasConfigs (ConfigsT m) where

52instance Monad m => HasConfigs (ConfigsT m) where

51 getConfigs = ConfigsT ask

53 getConfigs = ConfigsT ask

55+getTextConfig :: HasConfigs m => Text -> m (Maybe Text)

56+getTextConfig k = fmap T.decodeUtf8 <$> getConfig k

57+

53instance HasConfigs m => HasConfigs (BehaviorWriterT t w m)

58instance HasConfigs m => HasConfigs (BehaviorWriterT t w m)

54instance HasConfigs m => HasConfigs (DynamicWriterT t w m)

59instance HasConfigs m => HasConfigs (DynamicWriterT t w m)

55instance HasConfigs m => HasConfigs (EventWriterT t w m)

60instance HasConfigs m => HasConfigs (EventWriterT t w m)

lib/frontend/src/Obelisk/Frontend.hs+24−16

@@ -43,11 +43,11 @@ import qualified GHCJS.DOM as DOM

43import qualified GHCJS.DOM.Types as DOM

44import qualified GHCJS.DOM.History as DOM

45import qualified GHCJS.DOM.Window as DOM

46−import Language.Javascript.JSaddle (JSM, jsNull)

46+import Language.Javascript.JSaddle (MonadJSM, JSM, jsNull)

47import GHCJS.DOM (currentDocument)

48import GHCJS.DOM.Document (getHead)

49−import GHCJS.DOM.Node (removeChild_)

49+import GHCJS.DOM.Node (Node, removeChild_)

50−import GHCJS.DOM.NodeList (item, getLength)

50+import GHCJS.DOM.NodeList (IsNodeList, item, getLength)

51import GHCJS.DOM.ParentNode (querySelectorAll)

52import Obelisk.Frontend.Cookie

53import Obelisk.Route.Frontend

@@ -83,6 +83,7 @@ type ObeliskWidget js t route m =

83 , PrebuildAgnostic t route (Client m)

84 , HasConfigs m

85 , HasCookies m

86+ , MonadIO (Performable m)

86 )

87 )

88type PrebuildAgnostic t route m =

89type PrebuildAgnostic t route m =

@@ -105,13 +106,20 @@ removeHTMLConfigs :: JSM ()

105removeHTMLConfigs = void $ runMaybeT $ do

106removeHTMLConfigs = void $ runMaybeT $ do

106 doc <- MaybeT currentDocument

107 doc <- MaybeT currentDocument

107 hd <- MaybeT $ getHead doc

108 hd <- MaybeT $ getHead doc

108− es <- collToList =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

109+ es <- nodeListNodes =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

109 for_ es $ removeChild_ hd

110 for_ es $ removeChild_ hd

110− where

111+

111− collToList es = do

112+-- | Collect all nodes in the node list.

113+--

114+-- TODO: this and the version in exe-config/ghcjs/lookup should be

115+-- upstreamed to jsaddle.

116+nodeListNodes :: (IsNodeList l, MonadJSM m) => l -> m [Node]

117+nodeListNodes es = do

112− len <- getLength es

118+ len <- getLength es

113− lst <- traverse (item es) $ take (fromIntegral len) $ [0..] -- fun with unsigned types ...

119+ -- Warning! len is unsigned. If the NodeList is empty, we must avoid

120+ -- accidentally traversing over [0..maxBound::Word]

121+ nodes <- traverse (item es) $ if len == 0 then [] else [0..len-1]

114− pure $ catMaybes lst

122+ pure $ catMaybes nodes

115

123

116setInitialRoute :: Bool -> JSM ()

124setInitialRoute :: Bool -> JSM ()

117setInitialRoute useHash = do

125setInitialRoute useHash = do

@@ -137,7 +145,7 @@ data FrontendMode = FrontendMode

137-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp

145-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp

138runFrontend

146runFrontend

139 :: forall backendRoute route

147 :: forall backendRoute route

140− . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

148+ . Encoder Identity Identity (R (FullRoute backendRoute route)) PageName

141 -> Frontend (R route)

149 -> Frontend (R route)

142 -> JSM ()

150 -> JSM ()

143runFrontend validFullEncoder frontend = do

151runFrontend validFullEncoder frontend = do

@@ -165,14 +173,14 @@ runFrontend validFullEncoder frontend = do

165 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

173 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

166

174

167runFrontendWithConfigsAndCurrentRoute

175runFrontendWithConfigsAndCurrentRoute

168− :: forall backendRoute route

176+ :: forall backendRoute frontendRoute

169 . FrontendMode

177 . FrontendMode

170 -> Map Text ByteString

178 -> Map Text ByteString

171− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

179+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

172− -> Frontend (R route)

180+ -> Frontend (R frontendRoute)

173 -> JSM ()

181 -> JSM ()

174runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do

182runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do

175− let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _InR . _ObeliskRoute_App))

183+ let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _FullRoute_Frontend . _ObeliskRoute_App))

176 errorLeft = \case

184 errorLeft = \case

177 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."

185 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."

178 Right x -> Identity x

186 Right x -> Identity x

@@ -221,7 +229,7 @@ runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = d

221renderFrontendHtml

229renderFrontendHtml

222 :: ( t ~ DomTimeline

230 :: ( t ~ DomTimeline

223 , MonadIO m

231 , MonadIO m

224− , widget ~ RoutedT t r (SetRouteT t r (RouteToUrlT r (ConfigsT (CookiesT (PostBuildT t (StaticDomBuilderT t (PerformEventT t DomHost)))))))

232+ , widget ~ RoutedT t r (SetRouteT t r (RouteToUrlT r (ConfigsT (CookiesT (HydratableT (PostBuildT t (StaticDomBuilderT t (PerformEventT t DomHost))))))))

225 )

233 )

226 => Map Text ByteString

234 => Map Text ByteString

227 -> Cookies

235 -> Cookies

@@ -233,7 +241,7 @@ renderFrontendHtml

233 -> m ByteString

241 -> m ByteString

234renderFrontendHtml configs cookies urlEnc route frontend headExtra bodyExtra = do

242renderFrontendHtml configs cookies urlEnc route frontend headExtra bodyExtra = do

235 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline

243 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline

236− html <- fmap snd $ liftIO $ renderStatic $ fmap fst $ runCookiesT cookies $ runConfigsT configs $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $

244+ html <- fmap snd $ liftIO $ renderStatic $ runHydratableT $ fmap fst $ runCookiesT cookies $ runConfigsT configs $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $

237 el "html" $ do

245 el "html" $ do

238 el "head" $ do

246 el "head" $ do

239 baseTag

247 baseTag

lib/route/src/Obelisk/Route.hs+249−31

@@ -12,6 +12,7 @@

12{-# LANGUAGE PatternSynonyms #-}

13{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE StandaloneDeriving #-}

15{-# LANGUAGE TemplateHaskell #-}

16{-# LANGUAGE TemplateHaskell #-}

16{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

@@ -19,9 +20,11 @@

19{-# LANGUAGE ViewPatterns #-}

20{-# LANGUAGE ViewPatterns #-}

20module Obelisk.Route

21module Obelisk.Route

21 ( R

22 ( R

22− , pattern (:/)

23+ , (:.)

23 , (?/)

24 , (?/)

24 , hoistR

25 , hoistR

26+ , pattern (:.)

27+ , pattern (:/)

25 , PageName

28 , PageName

26 , PathQuery

29 , PathQuery

27 , Encoder

30 , Encoder

@@ -43,6 +46,9 @@ module Obelisk.Route

43 , checkEnum1EncoderFunc

46 , checkEnum1EncoderFunc

44 , unitEncoder

47 , unitEncoder

45 , pathOnlyEncoder

48 , pathOnlyEncoder

49+ , addPathSegmentEncoder

50+ , pathParamEncoder

51+ , pathLiteralEncoder

46 , singletonListEncoder

52 , singletonListEncoder

47 , unpackTextEncoder

53 , unpackTextEncoder

48 , prefixTextEncoder

54 , prefixTextEncoder

@@ -63,10 +69,15 @@ module Obelisk.Route

63 , shadowEncoder

69 , shadowEncoder

64 , prismEncoder

70 , prismEncoder

65 , rPrism

71 , rPrism

72+ , _R

66 , obeliskRouteEncoder

73 , obeliskRouteEncoder

67 , obeliskRouteSegment

74 , obeliskRouteSegment

68 , pageNameEncoder

75 , pageNameEncoder

69 , handleEncoder

76 , handleEncoder

77+ , FullRoute (..)

78+ , _FullRoute_Frontend

79+ , _FullRoute_Backend

80+ , mkFullRouteEncoder

70 , ObeliskRoute (..)

81 , ObeliskRoute (..)

71 , _ObeliskRoute_App

82 , _ObeliskRoute_App

72 , _ObeliskRoute_Resource

83 , _ObeliskRoute_Resource

@@ -91,7 +102,9 @@ module Obelisk.Route

91 , Decoder(..)

102 , Decoder(..)

92 , dmapEncoder

103 , dmapEncoder

93 , fieldMapEncoder

104 , fieldMapEncoder

105+ , pathFieldEncoder

94 , jsonEncoder

106 , jsonEncoder

107+ , byteStringsToPageName

95 ) where

108 ) where

109

97import Prelude hiding ((.), id)

110import Prelude hiding ((.), id)

@@ -102,8 +115,31 @@ import qualified Control.Categorical.Functor as Cat

102import Control.Categorical.Bifunctor

115import Control.Categorical.Bifunctor

103import Control.Category.Associative

116import Control.Category.Associative

104import Control.Category.Monoidal

117import Control.Category.Monoidal

105−import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))

118+import Control.Category.Braided

119+import Control.Lens

120+ ( Identity (..)

121+ , (^.)

122+ , (^?)

123+ , _Just

124+ , _Nothing

125+ , Cons(..)

126+ , from

127+ , imap

128+ , iso

129+ , Iso'

130+ , itraverse

131+ , makePrisms

132+ , Prism'

133+ , prism'

134+ , re

135+ , view

136+ , Wrapped (..)

137+ )

106import Control.Monad.Except

138import Control.Monad.Except

139+import Control.Monad.Writer (execWriter, tell)

140+import qualified Control.Monad.State.Strict as State

141+import Control.Monad.Trans (lift)

142+import qualified Data.ByteString as BS

107import qualified Data.ByteString.Lazy as BSL

143import qualified Data.ByteString.Lazy as BSL

108import Data.Dependent.Sum (DSum (..))

144import Data.Dependent.Sum (DSum (..))

109import Data.Dependent.Map (DMap)

145import Data.Dependent.Map (DMap)

@@ -174,6 +210,48 @@ mapSome f (Some a) = Some $ f a

174hoistR :: (forall x. f x -> g x) -> R f -> R g

210hoistR :: (forall x. f x -> g x) -> R f -> R g

175hoistR f (x :=> Identity y) = f x :/ y

211hoistR f (x :=> Identity y) = f x :/ y

176

212

213+--------------------------------------------------------------------------------

214+-- Dealing with pairs (i.e. non-dependently-typed subroutes/paths)

215+--------------------------------------------------------------------------------

216+

217+infixr 5 :.

218+type (:.) = (,)

219+

220+{-# COMPLETE (:.) #-}

221+pattern (:.) :: a -> b -> a :. b

222+pattern a :. b = (a, b)

223+

224+addPathSegmentEncoder

225+ :: ( Applicative check

226+ , MonadError Text parse

227+ )

228+ => Encoder check parse (Text, PageName) PageName

229+addPathSegmentEncoder = unsafeMkEncoder $ EncoderImpl

230+ { _encoderImpl_encode = \(ph, (pt, q)) -> (ph : pt, q)

231+ , _encoderImpl_decode = \(p, q) -> case p of

232+ [] -> throwError "Expected a path segment"

233+ ph : pt -> pure (ph, (pt, q))

234+ }

235+

236+pathParamEncoder

237+ :: forall check parse item rest.

238+ ( Applicative check

239+ , MonadError Text parse

240+ )

241+ => Encoder check parse item Text

242+ -> Encoder check parse rest PageName

243+ -> Encoder check parse (item :. rest) PageName

244+pathParamEncoder itemUnchecked restUnchecked = addPathSegmentEncoder . bimap itemUnchecked restUnchecked

245+

246+pathLiteralEncoder

247+ :: ( Applicative check

248+ , MonadError Text parse

249+ )

250+ => Text

251+ -> Encoder check parse a PageName

252+ -> Encoder check parse a PageName

253+pathLiteralEncoder t e = addPathSegmentEncoder . bimap (unitEncoder t) e . coidl

254+

177--------------------------------------------------------------------------------

255--------------------------------------------------------------------------------

178-- Encoder fundamentals

256-- Encoder fundamentals

179--------------------------------------------------------------------------------

257--------------------------------------------------------------------------------

@@ -207,7 +285,7 @@ decode e x = runIdentity (tryDecode e x)

207tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded

285tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded

208tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x

286tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x

209

287

210−-- | Similar to 'decode' above, once an encoder has been checked so that its check monad is Identity, it

288+-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it

211-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,

289-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,

212-- one should usually be applying decode and encode to the same 'Encoder'

290-- one should usually be applying decode and encode to the same 'Encoder'

213encode :: Encoder Identity parse decoded encoded -> decoded -> encoded

291encode :: Encoder Identity parse decoded encoded -> decoded -> encoded

@@ -257,6 +335,10 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E

257 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)

335 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)

258 }

336 }

259

337

338+instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where

339+ braid = isoEncoder (iso swap swap)

340+

341+

260instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where

342instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where

261 first f = bimap f id

343 first f = bimap f id

262instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where

344instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where

@@ -270,6 +352,34 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco

270 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve

352 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve

271 }

353 }

272

354

355+instance Monad parse => PFunctor Either (EncoderImpl parse) (EncoderImpl parse) where

356+ first f = bimap f id

357+instance Monad parse => QFunctor Either (EncoderImpl parse) (EncoderImpl parse) where

358+ second g = bimap id g

359+instance Monad parse => Bifunctor Either (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where

360+ bimap f g = EncoderImpl

361+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)

362+ , _encoderImpl_decode = \case

363+ Left a -> Left <$> _encoderImpl_decode f a

364+ Right b -> Right <$> _encoderImpl_decode g b

365+ }

366+

367+instance (Monad parse, Applicative check) => QFunctor Either (Encoder check parse) (Encoder check parse) where

368+ second g = bimap id g

369+instance (Monad parse, Applicative check) => PFunctor Either (Encoder check parse) (Encoder check parse) where

370+ first f = bimap f id

371+instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check parse) (Encoder check parse) (Encoder check parse) where

372+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)

373+

374+instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where

375+ associate = isoEncoder (iso (associate @(->) @Either) disassociate)

376+ disassociate = isoEncoder (iso disassociate associate)

377+

378+instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where

379+ braid = isoEncoder (iso swap swap)

380+

381+

382+

273instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where

383instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where

274 fmap e = Encoder $ do

384 fmap e = Encoder $ do

275 ve <- unEncoder e

385 ve <- unEncoder e

@@ -447,8 +557,9 @@ chainEncoder cons this rest = Encoder $ do

447 pure $ EncoderImpl

557 pure $ EncoderImpl

448 { _encoderImpl_decode = \v -> do

558 { _encoderImpl_decode = \v -> do

449 (here, following) <- _encoderImpl_decode consValid v

559 (here, following) <- _encoderImpl_decode consValid v

450− Some r <- _encoderImpl_decode thisValid here

560+ _encoderImpl_decode thisValid here >>= \case

561+ Some r ->

451− (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following

562+ (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following

452 , _encoderImpl_encode = \(r :/ s) ->

563 , _encoderImpl_encode = \(r :/ s) ->

453 _encoderImpl_encode consValid

564 _encoderImpl_encode consValid

454 ( _encoderImpl_encode thisValid $ Some r

565 ( _encoderImpl_encode thisValid $ Some r

@@ -668,10 +779,47 @@ joinPairTextEncoder = Encoder . \case

668 _ -> return (kt, T.drop (T.length separator) vt)

779 _ -> return (kt, T.drop (T.length separator) vt)

669 }

780 }

670

781

671−--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum

782+-- This slight generalization of 'rPrism' happens to be enough to write all our

672−-- Or, more likely, the user can compose it themselves

783+-- prism combinators so far.

784+dSumPrism

785+ :: forall f f' g

673−rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)

786+ . (forall a. Prism' (f a) (f' a))

674−rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)

787+ -> Prism' (DSum f g) (DSum f' g)

788+dSumPrism p = prism'

789+ (\(f' :=> x) -> f' ^. re p :=> x)

790+ (\(f :=> x) -> (:=> x) <$> (f ^? p))

791+

792+-- already in obelisk

793+rPrism

794+ :: forall f f'

795+ . (forall a. Prism' (f a) (f' a))

796+ -> Prism' (R f) (R f')

797+rPrism p = dSumPrism p

798+

799+dSumPrism'

800+ :: forall f g a

801+ . (forall b. Prism' (f b) (a :~: b))

802+ -> Prism' (DSum f g) (g a)

803+dSumPrism' p = dSumPrism p . iso (\(Refl :=> b) -> b) (Refl :=>)

804+

805+dSumGEqPrism

806+ :: GEq f

807+ => f a

808+ -> Prism' (DSum f g) (g a)

809+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)

810+

811+-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual

812+-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'

813+-- generalized a usual sum type.

814+--

815+-- [This is given the '_R' name of the "cannonical" prism not because it is the

816+-- most general, but because it seems the most useful for routes, and 'R' itself

817+-- trades generality for route-specificity.]

818+_R

819+ :: GEq f

820+ => f a

821+ -> Prism' (R f) a

822+_R variant = dSumGEqPrism variant . iso runIdentity Identity

675

823

676-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad

824-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad

677-- if the prism doesn't match.

825-- if the prism doesn't match.

@@ -715,6 +863,45 @@ handleEncoder recover e = Encoder $ do

715-- Actual obelisk route info

863-- Actual obelisk route info

716--------------------------------------------------------------------------------

864--------------------------------------------------------------------------------

717

865

866+-- | The typical full route type comprising all of an Obelisk application's routes.

867+-- Parameterised by the top level GADTs that define backend and frontend routes, respectively.

868+data FullRoute :: (* -> *) -> (* -> *) -> * -> * where

869+ FullRoute_Backend :: br a -> FullRoute br fr a

870+ FullRoute_Frontend :: ObeliskRoute fr a -> FullRoute br fr a

871+

872+instance (GShow br, GShow fr) => GShow (FullRoute br fr) where

873+ gshowsPrec p = \case

874+ FullRoute_Backend x -> showParen (p > 10) (showString "FullRoute_Backend " . gshowsPrec 11 x)

875+ FullRoute_Frontend x -> showParen (p > 10) (showString "FullRoute_Frontend " . gshowsPrec 11 x)

876+

877+instance (GEq br, GEq fr) => GEq (FullRoute br fr) where

878+ geq (FullRoute_Backend x) (FullRoute_Backend y) = geq x y

879+ geq (FullRoute_Frontend x) (FullRoute_Frontend y) = geq x y

880+ geq _ _ = Nothing

881+

882+instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where

883+ gcompare (FullRoute_Backend _) (FullRoute_Frontend _) = GLT

884+ gcompare (FullRoute_Frontend _) (FullRoute_Backend _) = GGT

885+ gcompare (FullRoute_Backend x) (FullRoute_Backend y) = gcompare x y

886+ gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y

887+

888+instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where

889+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]

890+ ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]

891+

892+-- | Build the typical top level application route encoder from a route for handling 404's,

893+-- and segment encoders for backend and frontend routes.

894+mkFullRouteEncoder

895+ :: (GCompare br, GCompare fr, GShow br, GShow fr, UniverseSome br, UniverseSome fr)

896+ => R (FullRoute br fr) -- ^ 404 handler

897+ -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single backend route segment

898+ -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single frontend route segment

899+ -> Encoder (Either Text) Identity (R (FullRoute br fr)) PageName

900+mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const missing) $

901+ pathComponentEncoder $ \case

902+ FullRoute_Backend backendRoute -> backendSegment backendRoute

903+ FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment

904+

718-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your

905-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your

719-- frontend.

906-- frontend.

720data ObeliskRoute :: (* -> *) -> * -> * where

907data ObeliskRoute :: (* -> *) -> * -> * where

@@ -844,7 +1031,7 @@ concat <$> mapM deriveRouteComponent

844 ]

1031 ]

845

1032

846makePrisms ''ObeliskRoute

1033makePrisms ''ObeliskRoute

847−

1034+makePrisms ''FullRoute

848deriveGEq ''Void1

1035deriveGEq ''Void1

849deriveGCompare ''Void1

1036deriveGCompare ''Void1

850

1037

@@ -852,27 +1039,27 @@ deriveGCompare ''Void1

852-- and query string). See 'checkEncoder' for how to produce a checked encoder.

1039-- and query string). See 'checkEncoder' for how to produce a checked encoder.

853renderBackendRoute

1040renderBackendRoute

854 :: forall br a.

1041 :: forall br a.

855− Encoder Identity Identity (R (Sum br a)) PageName

1042+ Encoder Identity Identity (R (FullRoute br a)) PageName

856 -> R br

1043 -> R br

857 -> Text

1044 -> Text

858−renderBackendRoute enc = renderObeliskRoute enc . hoistR InL

1045+renderBackendRoute enc = renderObeliskRoute enc . hoistR FullRoute_Backend

859

1046

860-- | Renders a frontend route with the supplied checked encoder

1047-- | Renders a frontend route with the supplied checked encoder

861renderFrontendRoute

1048renderFrontendRoute

862 :: forall a fr.

1049 :: forall a fr.

863− Encoder Identity Identity (R (Sum a (ObeliskRoute fr))) PageName

1050+ Encoder Identity Identity (R (FullRoute a fr)) PageName

864 -> R fr

1051 -> R fr

865 -> Text

1052 -> Text

866−renderFrontendRoute enc = renderObeliskRoute enc . hoistR (InR . ObeliskRoute_App)

1053+renderFrontendRoute enc = renderObeliskRoute enc . hoistR (FullRoute_Frontend . ObeliskRoute_App)

867

1054

868-- | Renders a route of the form typically found in an Obelisk project

1055-- | Renders a route of the form typically found in an Obelisk project

869renderObeliskRoute

1056renderObeliskRoute

870 :: forall a b.

1057 :: forall a b.

871− Encoder Identity Identity (R (Sum a b)) PageName

1058+ Encoder Identity Identity (R (FullRoute a b)) PageName

872− -> R (Sum a b)

1059+ -> R (FullRoute a b)

873 -> Text

1060 -> Text

874renderObeliskRoute e r =

1061renderObeliskRoute e r =

875− let enc :: Encoder Identity (Either Text) (R (Sum a b)) PathQuery

1062+ let enc :: Encoder Identity (Either Text) (R (FullRoute a b)) PathQuery

876 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)

1063 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)

877 in (T.pack . uncurry (<>)) $ encode enc r

1064 in (T.pack . uncurry (<>)) $ encode enc r

878

1065

@@ -882,14 +1069,9 @@ readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder

882integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer

1069integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer

883integralEncoder = prismEncoder (Numeric.Lens.integral)

1070integralEncoder = prismEncoder (Numeric.Lens.integral)

884

1071

885−pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>

1072+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>

886− Encoder check parse (Text, PageName) PageName

1073+ Encoder check parse (a, (as, b)) (as, b)

887−pathSegmentEncoder = unsafeMkEncoder EncoderImpl

1074+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate

888− { _encoderImpl_encode = \(x, (y, z)) -> (x:y, z)

889− , _encoderImpl_decode = \(xss, y) -> case xss of

890− [] -> throwError "not enough path segments"

891− (x:xs) -> pure (x, (xs, y))

892− }

893

1075

894newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }

1076newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }

895

1077

@@ -917,12 +1099,12 @@ dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do

917 , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'

1099 , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'

918 )

1100 )

919 , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do

1101 , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do

920− Some (k' :: k' t) <- tryDecode keyEncoder k

1102+ tryDecode keyEncoder k >>= \case

921− case DMap.lookup k' valueDecoders of

1103+ Some (k' :: k' t) -> case DMap.lookup k' valueDecoders of

922− Nothing -> throwError . T.pack . keyError $ gshow k'

1104+ Nothing -> throwError . T.pack . keyError $ gshow k'

923− Just (Decoder e) -> do

1105+ Just (Decoder e) -> do

924− v' <- tryDecode e v

1106+ v' <- tryDecode e v

925− return (k' :=> Identity v')

1107+ return (k' :=> Identity v')

926 }

1108 }

927

1109

928fieldMapEncoder :: forall check parse r.

1110fieldMapEncoder :: forall check parse r.

@@ -943,6 +1125,32 @@ fieldMapEncoder = unsafeEncoder $ do

943 Just (Identity v) -> return v

1125 Just (Identity v) -> return v

944 }

1126 }

945

1127

1128+-- this is in base 4.12 (GHC 8.6);

1129+newtype Ap f a = Ap {getAp :: f a}

1130+

1131+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where

1132+ Ap x <> Ap y = Ap (liftA2 (<>) x y)

1133+

1134+instance (Applicative f, Monoid a) => Monoid (Ap f a) where

1135+ mappend = (<>)

1136+ mempty = Ap (pure mempty)

1137+

1138+pathFieldEncoder :: forall a p check parse . (HasFields a, Monad check, MonadError Text parse, GCompare (Field a)) => (forall x. Field a x -> Encoder check parse x p) -> Encoder check parse (a, [p]) [p]

1139+pathFieldEncoder fieldEncoder = unsafeEncoder $ do

1140+ fieldEncoderPureMap :: DMap.DMap (Field a) (Decoder Identity parse p) <- getAp $ getConst $ tabulateFieldsA @a $ \f -> Const (Ap $ fmap (DMap.singleton f . Decoder) $ (checkEncoder @Identity) $ fieldEncoder f)

1141+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p

1142+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)

1143+ pure $ EncoderImpl

1144+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do

1145+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x

1146+ tell rest

1147+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case

1148+ [] -> throwError $ T.pack "not enough path components"

1149+ p:ps -> do

1150+ State.put ps

1151+ lift $ tryDecode (fieldEncoderPure f) p

1152+ }

1153+

946-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.

1154-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.

947jsonEncoder :: forall check parse r.

1155jsonEncoder :: forall check parse r.

948 ( ToJSON r

1156 ( ToJSON r

@@ -959,4 +1167,14 @@ jsonEncoder = unsafeEncoder $ do

959 Right x -> return x

1167 Right x -> return x

960 }

1168 }

961

1169

1170+-- Useful for app server integration.

1171+-- p must not start with slashes

1172+byteStringsToPageName :: BS.ByteString -> BS.ByteString -> PageName

1173+byteStringsToPageName p q =

1174+ let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)

1175+ pageNameEncoder' = bimap

1176+ (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)

1177+ (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)

1178+ in decode pageNameEncoder' (T.unpack (T.decodeUtf8 p), T.unpack (T.decodeUtf8 q))

1179+

962--TODO: decodeURIComponent as appropriate

1180--TODO: decodeURIComponent as appropriate

lib/route/src/Obelisk/Route/Frontend.hs+36−9

@@ -35,6 +35,8 @@ module Obelisk.Route.Frontend

35 , mapRoutedT

36 , subRoute

37 , subRoute_

38+ , subPairRoute

39+ , subPairRoute_

38 , maybeRoute

40 , maybeRoute

39 , maybeRoute_

41 , maybeRoute_

40 , maybeRouted

42 , maybeRouted

@@ -51,6 +53,7 @@ module Obelisk.Route.Frontend

51 , runRouteToUrlT

53 , runRouteToUrlT

52 , mapRouteToUrlT

54 , mapRouteToUrlT

53 , routeLink

55 , routeLink

56+ , routeLinkDynAttr

54 , dynRouteLink

57 , dynRouteLink

55 , adaptedUriPath

58 , adaptedUriPath

56 , setAdaptedUriPath

59 , setAdaptedUriPath

@@ -72,11 +75,13 @@ import Control.Monad.Trans.Control

72import Data.Coerce

75import Data.Coerce

73import Data.Dependent.Sum (DSum (..))

76import Data.Dependent.Sum (DSum (..))

74import Data.GADT.Compare

77import Data.GADT.Compare

78+import Data.Map (Map)

75import Data.Monoid

79import Data.Monoid

76import Data.Proxy

80import Data.Proxy

77import Data.Text (Text)

81import Data.Text (Text)

78import qualified Data.Text as T

82import qualified Data.Text as T

79import Data.Functor.Compose

83import Data.Functor.Compose

84+import Data.Functor.Misc

80import Reflex.Class

85import Reflex.Class

81import Reflex.Host.Class

86import Reflex.Host.Class

82import Reflex.PostBuild.Class

87import Reflex.PostBuild.Class

@@ -202,10 +207,18 @@ subRoute_ :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r

202subRoute_ f = factorRouted $ strictDynWidget_ $ \(c :=> r') -> do

207subRoute_ f = factorRouted $ strictDynWidget_ $ \(c :=> r') -> do

203 runRoutedT (f c) r'

208 runRoutedT (f c) r'

204

209

210+-- | Like 'subRoute_', but with a pair rather than an R

211+subPairRoute_ :: (MonadFix m, MonadHold t m, Eq a, Adjustable t m) => (a -> RoutedT t b m ()) -> RoutedT t (a, b) m ()

212+subPairRoute_ f = withRoutedT (fmap (\(a, b) -> Const2 a :/ b)) $ subRoute_ (\(Const2 a) -> f a)

213+

205subRoute :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r a -> RoutedT t a m b) -> RoutedT t (R r) m (Dynamic t b)

214subRoute :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r a -> RoutedT t a m b) -> RoutedT t (R r) m (Dynamic t b)

206subRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do

215subRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do

207 runRoutedT (f c) r'

216 runRoutedT (f c) r'

208

217

218+-- | Like 'subRoute_', but with a pair rather than an R

219+subPairRoute :: (MonadFix m, MonadHold t m, Eq a, Adjustable t m) => (a -> RoutedT t b m c) -> RoutedT t (a, b) m (Dynamic t c)

220+subPairRoute f = withRoutedT (fmap (\(a, b) -> Const2 a :/ b)) $ subRoute (\(Const2 a) -> f a)

221+

209maybeRoute_ :: (MonadFix m, MonadHold t m, Adjustable t m) => m () -> RoutedT t r m () -> RoutedT t (Maybe r) m ()

222maybeRoute_ :: (MonadFix m, MonadHold t m, Adjustable t m) => m () -> RoutedT t r m () -> RoutedT t (Maybe r) m ()

210maybeRoute_ n j = maybeRouted $ strictDynWidget_ $ \case

223maybeRoute_ n j = maybeRouted $ strictDynWidget_ $ \case

211 Nothing -> n

224 Nothing -> n

@@ -500,10 +513,10 @@ runRouteViewT routeEncoder switchover useHash a = do

500routeLink

513routeLink

501 :: forall t m a route.

514 :: forall t m a route.

502 ( DomBuilder t m

515 ( DomBuilder t m

503− , RouteToUrl (R route) m

516+ , RouteToUrl route m

504− , SetRoute t (R route) m

517+ , SetRoute t route m

505 )

518 )

506− => R route -- ^ Target route

519+ => route -- ^ Target route

507 -> m a -- ^ Child widget

520 -> m a -- ^ Child widget

508 -> m a

521 -> m a

509routeLink r w = do

522routeLink r w = do

@@ -515,9 +528,7 @@ routeLink r w = do

515 setRoute $ r <$ domEvent Click e

528 setRoute $ r <$ domEvent Click e

516 return a

529 return a

517

530

518−-- | A link widget that, when clicked, sets the route to current value of the

531+-- | Like 'routeLinkDynAttr' but without custom attributes.

519−-- provided dynamic route. In non-javascript contexts the value of the dynamic post

520−-- build is used so the link still works like 'routeLink'.

521dynRouteLink

532dynRouteLink

522 :: forall t m a route.

533 :: forall t m a route.

523 ( DomBuilder t m

534 ( DomBuilder t m

@@ -526,11 +537,27 @@ dynRouteLink

526 , SetRoute t (R route) m

537 , SetRoute t (R route) m

527 )

538 )

528 => Dynamic t (R route) -- ^ Target route

539 => Dynamic t (R route) -- ^ Target route

529− -> m a -- ^ Child widget

540+ -> m a -- ^ Child widget of the @a@ element

541+ -> m a

542+dynRouteLink = routeLinkDynAttr mempty

543+

544+-- | An @a@-tag link widget that, when clicked, sets the route to current value of the

545+-- provided dynamic route. In non-JavaScript contexts the value of the dynamic post

546+-- build is used so the link still works like 'routeLink'.

547+routeLinkDynAttr

548+ :: forall t m a route.

549+ ( DomBuilder t m

550+ , PostBuild t m

551+ , RouteToUrl (R route) m

552+ , SetRoute t (R route) m

553+ )

554+ => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored

555+ -> Dynamic t (R route) -- ^ Target route

556+ -> m a -- ^ Child widget of the @a@ element

530 -> m a

557 -> m a

531−dynRouteLink dr w = do

558+routeLinkDynAttr dAttr dr w = do

532 enc <- askRouteToUrl

559 enc <- askRouteToUrl

533− er <- dynamicAttributesToModifyAttributes $ ("href" =:) . enc <$> dr

560+ er <- dynamicAttributesToModifyAttributes $ zipDynWith (<>) (("href" =:) . enc <$> dr) dAttr

534 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

561 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

535 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

562 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

536 & elementConfig_modifyAttributes .~ er

563 & elementConfig_modifyAttributes .~ er

lib/run/obelisk-run.cabal+7

@@ -15,6 +15,7 @@ library

15 , dependent-sum

16 , dependent-sum-template

17 , ghcjs-dom

18+ , HsOpenSSL

18 , http-client

19 , http-client

19 , http-reverse-proxy

20 , http-reverse-proxy

20 , http-types

21 , http-types

@@ -36,11 +37,17 @@ library

36 , snap-core

37 , snap-core

37 , streaming-commons

38 , streaming-commons

38 , text

39 , text

40+ , time

39 , universe

41 , universe

42+ , utf8-string

40 , wai

43 , wai

41 , wai-websockets

44 , wai-websockets

42 , warp

45 , warp

46+ , warp-tls

43 , websockets

47 , websockets

44 exposed-modules:

48 exposed-modules:

45 Obelisk.Run

49 Obelisk.Run

46 ghc-options: -Wall -fwarn-redundant-constraints

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+67−25

@@ -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 #-}

@@ -20,11 +25,11 @@ import Control.Exception

20import Control.Lens ((%~), (^?), _Just, _Right)

25import Control.Lens ((%~), (^?), _Just, _Right)

21import qualified Data.Attoparsec.ByteString.Char8 as A

26import qualified Data.Attoparsec.ByteString.Char8 as A

22import Data.ByteString (ByteString)

27import Data.ByteString (ByteString)

28+import qualified Data.ByteString as BS

23import qualified Data.ByteString.Char8 as BSC

29import qualified Data.ByteString.Char8 as BSC

24import qualified Data.ByteString.Lazy.Char8 as BSLC

30import qualified Data.ByteString.Lazy.Char8 as BSLC

25−import Data.Dependent.Sum (DSum (..))

31+import qualified Data.ByteString.UTF8 as BSUTF8

26import Data.Functor.Identity

32import Data.Functor.Identity

27−import Data.Functor.Sum

28import Data.List (uncons)

33import Data.List (uncons)

29import Data.Map (Map)

34import Data.Map (Map)

30import qualified Data.Map as Map

35import qualified Data.Map as Map

@@ -35,6 +40,7 @@ import Data.String (fromString)

35import Data.Text (Text)

40import Data.Text (Text)

36import qualified Data.Text as T

41import qualified Data.Text as T

37import qualified Data.Text.Encoding as T

42import qualified Data.Text.Encoding as T

43+import Data.Time.Clock (getCurrentTime, addUTCTime)

38import Language.Javascript.JSaddle.Run (syncPoint)

44import Language.Javascript.JSaddle.Run (syncPoint)

39import Language.Javascript.JSaddle.WebSockets

45import Language.Javascript.JSaddle.WebSockets

40import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)

46import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)

@@ -44,6 +50,7 @@ import Network.Socket

44import Network.Wai (Application)

50import Network.Wai (Application)

45import qualified Network.Wai as W

51import qualified Network.Wai as W

46import Network.Wai.Handler.Warp

52import Network.Wai.Handler.Warp

53+import Network.Wai.Handler.WarpTLS

47import Network.Wai.Handler.Warp.Internal (settingsHost, settingsPort)

54import Network.Wai.Handler.Warp.Internal (settingsHost, settingsPort)

48import Network.WebSockets (ConnectionOptions)

55import Network.WebSockets (ConnectionOptions)

49import Network.WebSockets.Connection (defaultConnectionOptions)

56import Network.WebSockets.Connection (defaultConnectionOptions)

@@ -51,17 +58,24 @@ import qualified Obelisk.Asset.Serve.Snap as Snap

51import Obelisk.Backend

58import Obelisk.Backend

52import Obelisk.Frontend

59import Obelisk.Frontend

53import Obelisk.Route.Frontend

60import Obelisk.Route.Frontend

61+import qualified OpenSSL.PEM as PEM

62+import qualified OpenSSL.RSA as RSA

63+import qualified OpenSSL.X509 as X509

64+import qualified OpenSSL.X509.Request as X509Request

54import Reflex.Dom.Core

65import Reflex.Dom.Core

55import Snap.Core (Snap)

66import Snap.Core (Snap)

56import System.Environment

67import System.Environment

57import System.IO

68import System.IO

58import System.Process

69import System.Process

59−import System.Exit (ExitCode(..))

60import Text.URI (URI)

70import Text.URI (URI)

61import qualified Text.URI as URI

71import qualified Text.URI as URI

62import Text.URI.Lens

72import Text.URI.Lens

63import Web.Cookie

73import Web.Cookie

75+#if defined(IPROUTE_SUPPORTED)

76+import qualified System.Which

77+#endif

78+

65run

79run

66 :: Int -- ^ Port to run the backend

80 :: Int -- ^ Port to run the backend

67 -> ([Text] -> Snap ()) -- ^ Static asset handler

81 -> ([Text] -> Snap ()) -- ^ Static asset handler

@@ -81,8 +95,8 @@ run port serveStaticAsset backend frontend = do

81 runSnapWithCommandLineArgs $ do

95 runSnapWithCommandLineArgs $ do

82 getRouteWith validFullEncoder >>= \case

96 getRouteWith validFullEncoder >>= \case

83 Identity r -> case r of

97 Identity r -> case r of

84− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

98+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

85− InR obeliskRoute :=> Identity a ->

99+ FullRoute_Frontend obeliskRoute :/ a ->

86 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a

100 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a

87 let conf = defRunConfig { _runConfig_redirectPort = port }

101 let conf = defRunConfig { _runConfig_redirectPort = port }

88 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

102 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

@@ -93,7 +107,7 @@ runServeAsset rootPath = Snap.serveAsset "" rootPath . T.unpack . T.intercalate

107

94getConfigRoute :: Map Text ByteString -> Either Text URI

108getConfigRoute :: Map Text ByteString -> Either Text URI

95getConfigRoute configs = case Map.lookup "common/route" configs of

109getConfigRoute configs = case Map.lookup "common/route" configs of

96− Just r ->

110+ Just r ->

97 let stripped = T.strip (T.decodeUtf8 r)

111 let stripped = T.strip (T.decodeUtf8 r)

98 in case URI.mkURI stripped of

112 in case URI.mkURI stripped of

99 Just route -> Right route

113 Just route -> Right route

@@ -103,8 +117,8 @@ getConfigRoute configs = case Map.lookup "common/route" configs of

103runWidget

117runWidget

104 :: RunConfig

118 :: RunConfig

105 -> Map Text ByteString

119 -> Map Text ByteString

106− -> Frontend (R route)

120+ -> Frontend (R frontendRoute)

107− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

121+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

108 -> IO ()

122 -> IO ()

109runWidget conf configs frontend validFullEncoder = do

123runWidget conf configs frontend validFullEncoder = do

110 uri <- either (fail . T.unpack) pure $ getConfigRoute configs

124 uri <- either (fail . T.unpack) pure $ getConfigRoute configs

@@ -114,20 +128,43 @@ runWidget conf configs frontend validFullEncoder = do

114 beforeMainLoop = do

128 beforeMainLoop = do

115 putStrLn $ "Frontend running on " <> T.unpack (URI.render uri)

129 putStrLn $ "Frontend running on " <> T.unpack (URI.render uri)

116 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

130 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

131+ -- Providing TLS here will also incidentally provide it to proxied requests to the backend.

132+ prepareRunner = case uri ^? uriScheme . _Just . unRText of

133+ Just "https" -> do

134+ -- Generate a private key and self-signed certificate for TLS

135+ privateKey <- RSA.generateRSAKey' 2048 3

136+

137+ certRequest <- X509Request.newX509Req

138+ _ <- X509Request.setPublicKey certRequest privateKey

139+ _ <- X509Request.signX509Req certRequest privateKey Nothing

140+

141+ cert <- X509.newX509 >>= X509Request.makeX509FromReq certRequest

142+ _ <- X509.setPublicKey cert privateKey

143+ now <- getCurrentTime

144+ _ <- X509.setNotBefore cert $ addUTCTime (-1) now

145+ _ <- X509.setNotAfter cert $ addUTCTime (365 * 24 * 60 * 60) now

146+ _ <- X509.signX509 cert privateKey Nothing

147+

148+ certByteString <- BSUTF8.fromString <$> PEM.writeX509 cert

149+ privateKeyByteString <- BSUTF8.fromString <$> PEM.writePKCS8PrivateKey privateKey Nothing

150+

151+ return $ runTLSSocket (tlsSettingsMemory certByteString privateKeyByteString)

152+ _ -> return runSettingsSocket

153+ runner <- prepareRunner

117 bracket

154 bracket

118 (bindPortTCPRetry settings (logPortBindErr port) (_runConfig_retryTimeout conf))

155 (bindPortTCPRetry settings (logPortBindErr port) (_runConfig_retryTimeout conf))

119 close

156 close

120 (\skt -> do

157 (\skt -> do

121 man <- newManager defaultManagerSettings

158 man <- newManager defaultManagerSettings

122 app <- obeliskApp configs defaultConnectionOptions frontend validFullEncoder uri $ fallbackProxy redirectHost redirectPort man

159 app <- obeliskApp configs defaultConnectionOptions frontend validFullEncoder uri $ fallbackProxy redirectHost redirectPort man

123− runSettingsSocket settings skt app)

160+ runner settings skt app)

124

161

125obeliskApp

162obeliskApp

126− :: forall route backendRoute

163+ :: forall frontendRoute backendRoute

127 . Map Text ByteString

164 . Map Text ByteString

128 -> ConnectionOptions

165 -> ConnectionOptions

129− -> Frontend (R route)

166+ -> Frontend (R frontendRoute)

130− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

167+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

131 -> URI

168 -> URI

132 -> Application

169 -> Application

133 -> IO Application

170 -> IO Application

@@ -143,14 +180,14 @@ obeliskApp configs opts frontend validFullEncoder uri backend = do

143 let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])

180 let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])

144 Right (jsaddleWarpRouteValidEncoder :: Encoder Identity (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder

181 Right (jsaddleWarpRouteValidEncoder :: Encoder Identity (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder

145 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"

182 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"

146− return $ \req sendResponse -> case tryDecode validFullEncoder (W.pathInfo req, mempty) of --TODO: Query strings

183+ return $ \req sendResponse -> case tryDecode validFullEncoder $ byteStringsToPageName (BS.dropWhile (== (fromIntegral $ fromEnum '/')) $ W.rawPathInfo req) (BS.drop 1 $ W.rawQueryString req) of

147 Identity r -> case r of

184 Identity r -> case r of

148− InR (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :=> Identity jsaddleRoute -> case jsaddleRoute of

185+ FullRoute_Frontend (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :/ jsaddleRoute -> case jsaddleRoute of

149 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False

186 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False

150 _ -> flip jsaddle sendResponse $ req

187 _ -> flip jsaddle sendResponse $ req

151 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

188 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

152 }

189 }

153− InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do

190+ FullRoute_Frontend (ObeliskRoute_App appRouteComponent) :/ appRouteRest -> do

154 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)

191 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)

155 html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend

192 html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend

156 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html

193 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html

@@ -183,17 +220,22 @@ logPortBindErr p e = getProcessIdForPort p >>= \case

183 Nothing -> putStrLn $ "runWidget: " <> show e

220 Nothing -> putStrLn $ "runWidget: " <> show e

184 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."]

221 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."]

185

222

223+ssPath :: Maybe String

224+ssPath =

225+#if defined(IPROUTE_SUPPORTED)

226+ Just $(System.Which.staticWhich "ss")

227+#else

228+ Nothing

229+#endif

230+

186getProcessIdForPort :: Int -> IO (Maybe Int)

231getProcessIdForPort :: Int -> IO (Maybe Int)

187−getProcessIdForPort port = do

232+getProcessIdForPort port = case ssPath of

188− -- First check if 'ss' is available

233+ Just ss -> do

189− (c, _, _) <- readProcessWithExitCode "which" ["ss"] mempty

190− case c of

191− ExitSuccess -> do

192− xs <- lines <$> readProcess "ss" ["-lptn", "sport = " <> show port] mempty

234+ xs <- lines <$> readProcess ss ["-lptn", "sport = " <> show port] mempty

193− case uncons xs of

235+ case uncons xs of

194− Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x

236+ Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x

195− _ -> return Nothing

237+ _ -> return Nothing

196− _ -> return Nothing

238+ _ -> return Nothing

197

239

198parseSsPid :: A.Parser Int

240parseSsPid :: A.Parser Int

199parseSsPid = do

241parseSsPid = 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+118−63

@@ -3,7 +3,8 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE ViewPatterns #-}

7+{-# LANGUAGE TemplateHaskell #-}

7module Obelisk.SelfTest where

8module Obelisk.SelfTest where

9import Control.Exception (bracket, throw)

10import Control.Exception (bracket, throw)

@@ -11,7 +12,7 @@ import Control.Monad

11import Control.Monad.IO.Class

12import Control.Monad.IO.Class

12import Data.Bool (bool)

13import Data.Bool (bool)

13import Data.Function (fix)

14import Data.Function (fix)

14−import Data.Semigroup (Semigroup, (<>))

15+import Data.Semigroup ((<>))

15import qualified Data.Set as Set

16import qualified Data.Set as Set

16import Data.String

17import Data.String

17import Data.Text (Text)

18import Data.Text (Text)

@@ -21,11 +22,13 @@ import qualified Data.Text.IO as T

21import qualified Network.HTTP.Client as HTTP

22import qualified Network.HTTP.Client as HTTP

22import qualified Network.HTTP.Types as HTTP

23import qualified Network.HTTP.Types as HTTP

23import qualified Network.Socket as Socket

24import qualified Network.Socket as Socket

24−import Shelly

25+import Shelly hiding (cp)

25import System.Directory (withCurrentDirectory, getDirectoryContents)

26import System.Directory (withCurrentDirectory, getDirectoryContents)

26import System.Environment

27import System.Environment

27import System.Exit (ExitCode (..))

28import System.Exit (ExitCode (..))

28−import System.Info

29+import System.FilePath (replaceBaseName, takeBaseName)

30+import System.Which (staticWhich)

31+import qualified System.Info

29import System.IO (Handle, hClose)

32import System.IO (Handle, hClose)

30import System.IO.Temp

33import System.IO.Temp

31import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)

34import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)

@@ -43,16 +46,21 @@ 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+gitUserConfig :: [Text]

56+gitUserConfig = ["-c", "user.name=Obelisk Selftest", "-c", "user.email=noreply@example.com"]

49commit :: Text -> Sh ()

58commit :: Text -> Sh ()

50−commit msg = void $ run "git"

59+commit msg = void $ run "git" $ gitUserConfig <> [ "commit"

51− [ "commit"

52 , "--no-gpg-sign"

60 , "--no-gpg-sign"

53 , "--allow-empty"

61 , "--allow-empty"

54 , "-m"

62 , "-m"

55− , doubleQuotes msg

63+ , msg

56 ]

64 ]

58-- TODO replace Void and stop using loosely typed synchronous exceptions

66-- TODO replace Void and stop using loosely typed synchronous exceptions

@@ -68,32 +76,64 @@ tshow = T.pack . show

68shellyOb :: MonadIO m => (Sh a -> Sh a) -> Sh a -> m a

76shellyOb :: MonadIO m => (Sh a -> Sh a) -> Sh a -> m a

69shellyOb f obTest = shelly $ f obTest

77shellyOb f obTest = shelly $ f obTest

79+

71main :: IO ()

80main :: IO ()

72main = do

81main = do

73 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

82 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

74− isVerbose <- (elem "-v") <$> getArgs

83+ isVerbose <- elem "-v" <$> getArgs

75 unless isVerbose $

84 unless isVerbose $

76 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

85 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

77 let verbosity = bool silently verbosely isVerbose

86 let verbosity = bool silently verbosely isVerbose

87+ nixBuild args = run "nix-build" ("--no-out-link" : args)

78− obeliskImpl <- fromString <$> getEnv "OBELISK_IMPL"

88+ obeliskImplRaw <- fromString <$> getEnv "OBELISK_IMPL"

89+ let

90+ withObeliskImpl f =

91+ withSystemTempDirectory "obelisk-impl-copy" $ \(fromString -> obeliskImpl) -> do

92+ void . shellyOb verbosity $ chdir obeliskImpl $ do

93+ user <- T.strip <$> run "whoami" []

94+ run_ cp ["-rT", toTextIgnore obeliskImplRaw, toTextIgnore obeliskImpl]

95+ run_ "chown" ["-R", user, toTextIgnore obeliskImpl]

96+ run_ "chmod" ["-R", "g-rw,o-rw", toTextIgnore obeliskImpl]

97+ f obeliskImpl

98+

99+ withInitCache f obeliskImpl =

100+ withSystemTempDirectory "init Cache λ" $ \initCache -> do

101+ -- Setup the ob init cache

102+ void . shellyOb verbosity $ chdir initCache $ do

103+ run_ "ob" ["init", "--symlink", toTextIgnore obeliskImpl]

104+ run_ "git" ["init"]

105+

106+ f initCache

107+

108+ withObeliskImplAndInitCache f =

109+ withObeliskImpl $ \impl -> withInitCache (f impl) impl

110+

79 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

111 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

80− [p0, p1, p2, p3] <- liftIO $ getFreePorts 4

112+

81− withSystemTempDirectory "initCache" $ \initCache -> do

113+ withObeliskImplAndInitCache $ \obeliskImpl initCache ->

82− -- Setup the ob init cache

83− void . shellyOb verbosity $ chdir (fromString initCache) $ do

84− run_ "ob" ["init"]

85− run_ "git" ["init"]

86 hspec $ parallel $ do

114 hspec $ parallel $ do

87 let shelly_ = void . shellyOb verbosity

115 let shelly_ = void . shellyOb verbosity

116

117+ defaultTmpDirName = "test λ"

118+

89− inTmp :: (Shelly.FilePath -> Sh a) -> IO ()

119+ inTmp' :: FilePath -> (FilePath -> Sh a) -> IO ()

90− inTmp f = withTmp (chdir <*> f)

120+ inTmp' dirname f = withTmp' dirname (chdir <*> f)

121+ inTmp = inTmp' defaultTmpDirName

122

92− withTmp f = shelly_ . withSystemTempDirectory "test" $ f . fromString

123+ withTmp' dirname f = shelly_ . withSystemTempDirectory dirname $ f . fromString

124+ withTmp = withTmp' defaultTmpDirName

125

94− inTmpObInit f = inTmp $ \dir -> do

126+ inTmpObInit' dirname f = inTmp' dirname $ \dir -> do

95− run_ "cp" ["-a", fromString $ initCache <> "/.", toTextIgnore dir]

127+ run_ cp ["-rT", fromString initCache, toTextIgnore dir]

96 f dir

128 f dir

129+ inTmpObInit = inTmpObInit' defaultTmpDirName

130+

131+ -- To be used in tests that change the obelisk impl directory

132+ inTmpObInitWithImplCopy f = inTmpObInit $ \dir ->

133+ withObeliskImpl $ \(fromString -> implCopy) -> do

134+ run_ "rm" [thunk]

135+ run_ "ln" ["-s", implCopy, thunk]

136+ f dir

137

98 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b

138 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b

99 assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b

139 assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b

@@ -115,9 +155,9 @@ main = do

115 describe "ob init" $ parallel $ do

155 describe "ob init" $ parallel $ do

116 it "works with default impl" $ inTmp $ \_ -> run "ob" ["init"]

156 it "works with default impl" $ inTmp $ \_ -> run "ob" ["init"]

117 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

157 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

118− it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]

158+ it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", toTextIgnore obeliskImpl]

119− it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init" $ \dir -> do

159+ it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init λ" $ \dir -> do

120− let p force = (proc "ob" $ "--no-handoff" : "init" : if force then ["--force"] else []) { cwd = Just dir }

160+ let p force = (System.Process.proc "ob" $ "--no-handoff" : "init" : ["--force"|force]) { cwd = Just dir }

121 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

161 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

122 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

162 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

123 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

163 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

@@ -127,55 +167,62 @@ main = do

127 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

167 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

128 ls tmp >>= liftIO . assertEqual "" []

168 ls tmp >>= liftIO . assertEqual "" []

129

169

130− it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $ do

170+ it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $

131− configs <- getConfigs

132− withCurrentDirectory (T.unpack $ toTextIgnore tmp) $

171+ withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do

172+ configs <- getConfigs

133 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

173 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

134

174

135 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

175 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

136 -- when not run by 'nix-build --attr selftest'

176 -- when not run by 'nix-build --attr selftest'

137− describe "ob run" $ parallel $ do

177+ describe "ob run" $ {- NOT parallel $ -} do

138− it "works in root directory" $ inTmpObInit $ \_ -> do

178+ it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir Nothing httpManager

139− testObRunInDir p0 p1 Nothing httpManager

140− it "works in sub directory" $ inTmpObInit $ \_ -> do

141− testObRunInDir p2 p3 (Just "frontend") httpManager

179+ it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir (Just "frontend") httpManager

180+ it "works with differently named cabal files" $ inTmpObInit $ \_ -> do

181+ changeCabalPackageName "backend/backend.cabal" "new-backend"

182+ testObRunInDir Nothing httpManager

142

183

143 describe "obelisk project" $ parallel $ do

184 describe "obelisk project" $ parallel $ do

144− it "can build obelisk command" $ inTmpObInit $ \_ -> run "nix-build" ["-A", "command" , obeliskImpl]

185+ it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskImpl]

145− it "can build obelisk skeleton" $ inTmpObInit $ \_ -> run "nix-build" ["-A", "skeleton", obeliskImpl]

186+ it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", toTextIgnore obeliskImpl]

146− it "can build obelisk shell" $ inTmpObInit $ \_ -> run "nix-build" ["-A", "shell", obeliskImpl]

187+ it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", toTextIgnore obeliskImpl]

147− -- See https://github.com/obsidiansystems/obelisk/issues/101

148− -- it "can build everything" $ shelly_ $ run "nix-build" [obeliskImpl]

188+ it "can build everything" $ inTmpObInit $ \_ -> nixBuild [toTextIgnore obeliskImpl]

149

189

150 describe "blank initialized project" $ parallel $ do

190 describe "blank initialized project" $ parallel $ do

151

191

152− it "can build ghc.backend" $ inTmpObInit $ \_ -> do

192+ it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]

153− run "nix-build" ["--no-out-link", "-A", "ghc.backend"]

154− it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> do

193+ it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]

155− run "nix-build" ["--no-out-link", "-A", "ghcjs.frontend"]

156

194

157− if os == "darwin"

195+ if System.Info.os == "darwin"

158− then it "can build ios" $ inTmpObInit $ \_ -> run "nix-build" ["--no-out-link", "-A", "ios.frontend" ]

196+ then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

159− else it "can build android" $ inTmpObInit $ \_ -> run "nix-build" ["--no-out-link", "-A", "android.frontend"]

197+ else it "can build android after accepting license" $ inTmpObInit $ \dir -> do

198+ let defaultNixPath = dir </> ("default.nix" :: FilePath)

199+ writefile defaultNixPath

200+ =<< T.replace

201+ "# config.android_sdk.accept_license = false;"

202+ "config.android_sdk.accept_license = true;"

203+ <$> readfile defaultNixPath

204+ nixBuild ["-A", "android.frontend"]

160

205

161 forM_ ["ghc", "ghcjs"] $ \compiler -> do

206 forM_ ["ghc", "ghcjs"] $ \compiler -> do

162 let

207 let

163− shell = "shells." <> compiler

208+ shellName = "shells." <> compiler

164− inShell cmd' = run "nix-shell" ["-A", fromString shell, "--run", cmd']

209+ inShell cmd' = run_ "nix-shell" ["default.nix", "-A", fromString shellName, "--run", cmd']

165− it ("can enter " <> shell) $ inTmpObInit $ \_ -> inShell "exit"

210+ it ("can enter " <> shellName) $ inTmpObInit $ \_ -> inShell "exit"

166− it ("can build in " <> shell) $ inTmpObInit $ \_ -> inShell $ "cabal new-build --" <> fromString compiler <> " all"

211+ -- NOTE: We override the temporary directory name because cabal has a bug preventing new-build from working

167−

212+ -- in a path that has unicode characters.

168− it "can build reflex project" $ inTmpObInit $ \_ -> do

213+ it ("can build in " <> shellName) $ inTmpObInit' "test" $ \_ -> inShell $

169− run "nix-build" []

214+ T.pack cabalPath <> " --version; " <> T.pack cabalPath <> " new-build --" <> T.pack compiler <> " all"

170−

215+

171− it "has idempotent thunk update" $ inTmpObInit $ \_ -> do

216+ it "has idempotent thunk update" $ inTmpObInitWithImplCopy $ \_ -> do

217+ _ <- pack

172 u <- update

218 u <- update

173 uu <- update

219 uu <- update

174 assertRevEQ u uu

220 assertRevEQ u uu

175

221

176 describe "ob thunk pack/unpack" $ parallel $ do

222 describe "ob thunk pack/unpack" $ parallel $ do

177− it "has thunk pack and unpack inverses" $ inTmpObInit $ \_ -> do

223+ it "has thunk pack and unpack inverses" $ inTmpObInitWithImplCopy $ \_ -> do

178

224

225+ _ <- pack

179 e <- commitAll

226 e <- commitAll

180 eu <- unpack

227 eu <- unpack

181 eup <- pack

228 eup <- pack

@@ -194,7 +241,7 @@ main = do

194 branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]

241 branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]

195 liftIO $ assertEqual "" branch (T.strip branch')

242 liftIO $ assertEqual "" branch (T.strip branch')

196

243

197− it "can pack and unpack plain git repos" $ do

244+ it "can pack and unpack plain git repos" $

198 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

245 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

199 let repo = toTextIgnore $ dir </> ("repo" :: String)

246 let repo = toTextIgnore $ dir </> ("repo" :: String)

200 run_ "git" ["clone", "https://github.com/haskell/process.git", repo]

247 run_ "git" ["clone", "https://github.com/haskell/process.git", repo]

@@ -213,7 +260,6 @@ main = do

213 testThunkPack $ fromText repo

260 testThunkPack $ fromText repo

214

261

215 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

262 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

216− void $ unpack

217 testThunkPack (dir </> thunk)

263 testThunkPack (dir </> thunk)

218

264

219 describe "ob thunk update --branch" $ parallel $ do

265 describe "ob thunk update --branch" $ parallel $ do

@@ -234,11 +280,12 @@ main = do

234

280

235

281

236-- | Run `ob run` in the given directory (maximum of one level deep)

282-- | Run `ob run` in the given directory (maximum of one level deep)

237−testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()

283+testObRunInDir :: Maybe FilePath -> HTTP.Manager -> Sh ()

238−testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do

284+testObRunInDir mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do

285+ [p0, p1] <- liftIO $ getFreePorts 2

239 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison

286 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison

240 writefile "config/common/route" $ uri p0

287 writefile "config/common/route" $ uri p0

241− maybe id chdir mdir $ runHandle "ob" ["run"] $ \stdout -> do

288+ maybe id chdir mdir $ runHandle "ob" ["run", "-v"] $ \stdout -> do

242 firstUri <- handleObRunStdout httpManager stdout

289 firstUri <- handleObRunStdout httpManager stdout

243 let newUri = uri p1

290 let newUri = uri p1

244 when (firstUri == newUri) $ errorExit $

291 when (firstUri == newUri) $ errorExit $

@@ -249,7 +296,7 @@ testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure ();

249 then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri

296 then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri

250 else exit 0

297 else exit 0

251

298

252−testThunkPack :: Shelly.FilePath -> Sh ()

299+testThunkPack :: FilePath -> Sh ()

253testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do

300testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do

254 let pack' = readProcessWithExitCode "ob" ["thunk", "pack", T.unpack $ toTextIgnore path'] ""

301 let pack' = readProcessWithExitCode "ob" ["thunk", "pack", T.unpack $ toTextIgnore path'] ""

255 ensureThunkPackFails q = liftIO $ pack' >>= \case

302 ensureThunkPackFails q = liftIO $ pack' >>= \case

@@ -270,7 +317,7 @@ testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $

270 liftIO $ T.hPutStrLn handle "test file" >> hClose handle

317 liftIO $ T.hPutStrLn handle "test file" >> hClose handle

271 ensureThunkPackFails "modified"

318 ensureThunkPackFails "modified"

272 -- Existing stashes

319 -- Existing stashes

273− void $ git ["stash"]

320+ void $ git $ gitUserConfig <> [ "stash" ]

274 ensureThunkPackFails "has stashes"

321 ensureThunkPackFails "has stashes"

275

322

276-- | Blocks until a non-empty line is available

323-- | Blocks until a non-empty line is available

@@ -292,7 +339,7 @@ alterRouteTo uri stdout = do

292

339

293-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

340-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

294handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

341handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

295−handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) -> do

342+handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) ->

296 liftIO (T.hGetLine stdout) >>= \t -> case state of

343 liftIO (T.hGetLine stdout) >>= \t -> case state of

297 ObRunState_Init

344 ObRunState_Init

298 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)

345 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)

@@ -315,6 +362,14 @@ obRunCheck httpManager _stdout frontendUri = do

315 req frontendUri >>= \r -> when (HTTP.responseStatus r /= HTTP.ok200) $ errorExit $

362 req frontendUri >>= \r -> when (HTTP.responseStatus r /= HTTP.ok200) $ errorExit $

316 "Request to frontend server failed: " <> T.pack (show r)

363 "Request to frontend server failed: " <> T.pack (show r)

317

364

365+-- | Rename a cabal file and do a really dumb, brittle search/replace in its content to update the name.

366+changeCabalPackageName :: FilePath -> Text -> Sh ()

367+changeCabalPackageName cabalFile newName = do

368+ contents <- readfile cabalFile

369+ writefile (replaceBaseName cabalFile (T.unpack newName)) $

370+ T.replace (" " <> T.pack (takeBaseName cabalFile)) (" " <> newName) contents -- WARNING: Super brittle

371+ rm cabalFile

372+

318getFreePorts :: Int -> IO [Socket.PortNumber]

373getFreePorts :: Int -> IO [Socket.PortNumber]

319getFreePorts 0 = pure []

374getFreePorts 0 = pure []

320getFreePorts n = Socket.withSocketsDo $ do

375getFreePorts n = Socket.withSocketsDo $ do

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−89

@@ -1,91 +1,10 @@

1−{ self-args ? {}

1+{

2−, local-self ? import ./. self-args

2+ supportedSystems ? [ "x86_64-linux" "x86_64-darwin" ]

3}:

4+rec {

5+ recurseForDerivations = true;

6+ build = import ./all-builds.nix { inherit supportedSystems; };

7+ test = import ./all-tests.nix { inherit supportedSystems; };

5−let

9+ inherit (build) metaCache;

6− inherit (local-self.nixpkgs) lib runCommand nix;

10+}

7−

8− cacheBuildSystems = [ "x86_64-linux" "x86_64-darwin" ];

9−

10− obeliskPackagesCommon = [

11− "obelisk-frontend"

12− "obelisk-route"

13− "obelisk-executable-config-lookup"

14− ];

15−

16− obeliskPackagesBackend = obeliskPackagesCommon ++ [

17− "obelisk-asset-manifest"

18− "obelisk-asset-serve-snap"

19− "obelisk-backend"

20− "obelisk-cliapp"

21− "obelisk-command"

22− "obelisk-executable-config-inject"

23− "obelisk-frontend"

24− "obelisk-run"

25− "obelisk-route"

26− "obelisk-selftest"

27− "obelisk-snap-extras"

28− ];

29−

30− pnameToAttrs = pkgsSet: pnames:

31− lib.listToAttrs (map

32− (name: { inherit name; value = pkgsSet.${name}; })

33− pnames);

34−

35− concatDepends = let

36− extractDeps = x: (x.override {

37− mkDerivation = drv: {

38− out = builtins.concatLists [

39− (drv.buildDepends or [])

40− (drv.libraryHaskellDepends or [])

41− (drv.executableHaskellDepends or [])

42− ];

43− };

44− }).out;

45− in pkgAttrs: builtins.concatLists (map extractDeps (builtins.attrValues pkgAttrs));

46−

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

48− obelisk = import ./. { inherit system; };

49− reflex-platform = obelisk.reflex-platform;

50− ghc = pnameToAttrs

51− obelisk.haskellPackageSets.ghc

52− obeliskPackagesBackend;

53− ghcjs = pnameToAttrs

54− obelisk.haskellPackageSets.ghcjs

55− obeliskPackagesCommon;

56− cachePackages = builtins.concatLists [

57− (builtins.attrValues ghc)

58− (builtins.attrValues ghcjs)

59− (concatDepends ghc)

60− (concatDepends ghcjs)

61− ];

62− command = local-self.command;

63− serverExeSkeleton = (import ./skeleton { obelisk = local-self; }).exe;

64− androidObelisk = import ./. (self-args // {

65− config.android_sdk.accept_license = true;

66− });

67− androidSkeleton = (import ./skeleton { obelisk = androidObelisk; }).android.frontend;

68− iosObelisk = import ./. (self-args // {

69− system = "x86_64-darwin";

70− iosSdkVersion = "10.2";

71− });

72− iosSkeleton = (import ./skeleton { obelisk = iosObelisk; }).ios.frontend;

73− in {

74− inherit

75− command

76− ghc ghcjs

77− serverExeSkeleton

78− iosSkeleton

79− androidSkeleton;

80− cache = reflex-platform.pinBuildInputs

81− "obelisk-${system}"

82− cachePackages

83− [command serverExeSkeleton iosSkeleton androidSkeleton];

84− });

85−

86− metaCache = local-self.pinBuildInputs

87− "obelisk-everywhere"

88− (map (a: a.cache) (builtins.attrValues perPlatform))

89− [];

90−

91−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+1−3

@@ -1,6 +1,4 @@

1−{-# LANGUAGE EmptyCase #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE TypeFamilies #-}

3{-# LANGUAGE TypeFamilies #-}

6module Backend where

4module Backend where

@@ -11,5 +9,5 @@ import Obelisk.Backend

11backend :: Backend BackendRoute FrontendRoute

9backend :: Backend BackendRoute FrontendRoute

12backend = Backend

10backend = Backend

13 { _backend_run = \serve -> serve $ const $ return ()

11 { _backend_run = \serve -> serve $ const $ return ()

14− , _backend_routeEncoder = backendRouteEncoder

12+ , _backend_routeEncoder = fullRouteEncoder

15 }

13 }

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+13−18

@@ -1,15 +1,14 @@

1{-# LANGUAGE EmptyCase #-}

2{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE LambdaCase #-}

5−{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE TemplateHaskell #-}

7{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE KindSignatures #-}

8−{-# LANGUAGE EmptyCase #-}

6+{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE FlexibleInstances #-}

11{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE OverloadedStrings #-}

12−

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeFamilies #-}

13module Common.Route where

12module Common.Route where

15{- -- You will probably want these imports for composing Encoders.

14{- -- You will probably want these imports for composing Encoders.

@@ -19,7 +18,6 @@ import Control.Category

20import Data.Text (Text)

19import Data.Text (Text)

21import Data.Functor.Identity

20import Data.Functor.Identity

22−import Data.Functor.Sum

24import Obelisk.Route

22import Obelisk.Route

25import Obelisk.Route.TH

23import Obelisk.Route.TH

@@ -34,17 +32,14 @@ data FrontendRoute :: * -> * where

34 FrontendRoute_Main :: FrontendRoute ()

32 FrontendRoute_Main :: FrontendRoute ()

35 -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.

33 -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.

37−backendRouteEncoder

35+fullRouteEncoder

38− :: Encoder (Either Text) Identity (R (Sum BackendRoute (ObeliskRoute FrontendRoute))) PageName

36+ :: Encoder (Either Text) Identity (R (FullRoute BackendRoute FrontendRoute)) PageName

37+fullRouteEncoder = mkFullRouteEncoder

39−backendRouteEncoder = handleEncoder (const (InL BackendRoute_Missing :/ ())) $

38+ (FullRoute_Backend BackendRoute_Missing :/ ())

40− pathComponentEncoder $ \case

39+ (\case

41− InL backendRoute -> case backendRoute of

42− BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty

40+ BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty)

43− InR obeliskRoute -> obeliskRouteSegment obeliskRoute $ \case

41+ (\case

44− -- The encoder given to PathEnd determines how to parse query parameters,

45− -- in this example, we have none, so we insist on it.

46− FrontendRoute_Main -> PathEnd $ unitEncoder mempty

42+ FrontendRoute_Main -> PathEnd $ unitEncoder mempty)

47−

49concat <$> mapM deriveRouteComponent

44concat <$> mapM deriveRouteComponent

50 [ ''BackendRoute

45 [ ''BackendRoute

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-bin/main.hs+1−1

@@ -6,5 +6,5 @@ import Reflex.Dom

7main :: IO ()

8main = do

9− let Right validFullEncoder = checkEncoder backendRouteEncoder

9+ let Right validFullEncoder = checkEncoder fullRouteEncoder

10 run $ runFrontend validFullEncoder frontend

skeleton/frontend/src/Frontend.hs+23−5

@@ -1,30 +1,48 @@

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"

26 case exampleConfig of

44 case exampleConfig of

27 Nothing -> text "No config file found in config/common/example"

45 Nothing -> text "No config file found in config/common/example"

28− Just s -> text (T.decodeUtf8 s)

46+ Just s -> text $ T.decodeUtf8 s

29 return ()

47 return ()

30 }

48 }

skeleton/shell.nixnew file+1

@@ -0,0 +1 @@

1+(import ./. {}).shells.ghc

skeleton/static/main.cssnew file+3

@@ -0,0 +1,3 @@

1+p {

2+ color: red;

3+}