1dbc012 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge remote-tracking branch 'origin/qa' into fix-package-name

1dbc012Elliot Cameron7 years ago

.gitignore+1

compare with master

unifiedsplit

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

2**/.cabal-sandbox

3**/cabal.sandbox.config

4result

5+result-*

5*.o

6*.o

6*.hi

7*.hi

7TAGS

8TAGS

.hlint.yamlnew file+65

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

1+# HLint configuration file

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

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

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

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

9+# Specify additional command line arguments

10+#

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

12+

13+

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

15+#

16+# - extensions:

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

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

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

20+#

21+# - flags:

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

23+#

24+# - modules:

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

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

27+#

28+# - functions:

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

30+

31+

32+# Add custom hints for this project

33+#

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

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

36+

37+

38+# Turn on hints that are off by default

39+#

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

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

42+#

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

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

45+#

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

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

48+

49+

50+# Ignore some builtin hints

51+- ignore: {name: Redundant do}

52+- ignore: {name: Redundant flip}

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

54+- ignore: {name: Use camelCase}

55+- ignore: {name: Use if}

56+- ignore: {name: Use unless}

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

58+

59+

60+# Define some custom infix operators

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

62+

63+

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

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

ChangeLog.md+10

@@ -2,6 +2,16 @@

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+* Bump reflex-platform which, notably, bumps nixpkgs to 19.09. ([#585](https://github.com/obsidiansystems/obelisk/pull/585))

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

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

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

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

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

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

14+

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

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

7* Generalised `pathSegmentEncoder`, added `pathFieldEncoder`.

17* Generalised `pathSegmentEncoder`, added `pathFieldEncoder`.

README.md+1−1

@@ -152,7 +152,7 @@ For further information see [the Haskell section](https://nixos.org/nixpkgs/manu

152

153### Running over https

154

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

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

156

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

158

acme.nixdeleted−397

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

1−### COPIED FROM

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

3−###

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

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

6−

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

8−

9−with lib;

10−

11−let

12−

13− cfg = config.security.acme;

14−

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

16− options = {

17− webroot = mkOption {

18− type = types.str;

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

20− description = ''

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

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

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

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

25− be available (notice unencrypted HTTP).

26− '';

27− };

28−

29− domain = mkOption {

30− type = types.str;

31− default = name;

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

33− };

34−

35− email = mkOption {

36− type = types.nullOr types.str;

37− default = null;

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

39− };

40−

41− user = mkOption {

42− type = types.str;

43− default = "root";

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

45− };

46−

47− group = mkOption {

48− type = types.str;

49− default = "root";

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

51− };

52−

53− allowKeysForGroup = mkOption {

54− type = types.bool;

55− default = false;

56− description = ''

57− Give read permissions to the specified group

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

59− '';

60− };

61−

62− postRun = mkOption {

63− type = types.lines;

64− default = "";

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

66− description = ''

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

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

69− be reloaded.

70−

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

72− '';

73− };

74−

75− plugins = mkOption {

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

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

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

79− ]);

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

81− description = ''

82− Plugins to enable. With default settings simp_le will

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

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

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

86− '';

87− };

88−

89− activationDelay = mkOption {

90− type = types.nullOr types.str;

91− default = null;

92− description = ''

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

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

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

96− '';

97− };

98−

99− preDelay = mkOption {

100− type = types.lines;

101− default = "";

102− description = ''

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

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

105−

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

107− '';

108− };

109−

110− extraDomains = mkOption {

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

112− default = {};

113− example = literalExample ''

114− {

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

116− "mydomain.org" = null;

117− }

118− '';

119− description = ''

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

121− own server roots if needed.

122− '';

123− };

124− };

125− };

126−

127−in

128−

129−{

130−

131− ###### interface

132−

133− options = {

134− security.acme = {

135− directory = mkOption {

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

137− type = types.str;

138− description = ''

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

140− '';

141− };

142−

143− validMin = mkOption {

144− type = types.int;

145− default = 30 * 24 * 3600;

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

147− };

148−

149− renewInterval = mkOption {

150− type = types.str;

151− default = "weekly";

152− description = ''

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

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

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

156− '';

157− };

158−

159− preliminarySelfsigned = mkOption {

160− type = types.bool;

161− default = true;

162− description = ''

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

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

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

166−

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

168− can later reload the correct ACME certificates.

169− '';

170− };

171−

172− production = mkOption {

173− type = types.bool;

174− default = true;

175− description = ''

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

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

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

179−

180− See

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

182− for more detail.

183− '';

184− };

185−

186− certs = mkOption {

187− default = { };

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

189− description = ''

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

191− '';

192− example = literalExample ''

193− {

194− "example.com" = {

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

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

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

198− };

199− "bar.example.com" = {

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

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

202− };

203− }

204− '';

205− };

206− };

207− };

208−

209− ###### implementation

210− config = mkMerge [

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

212−

213− systemd.services = let

214− services = concatLists servicesLists;

215− servicesLists = mapAttrsToList certToServices cfg.certs;

216− certToServices = cert: data:

217− let

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

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

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

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

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

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

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

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

226− acmeService = {

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

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

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

230− serviceConfig = {

231− Type = "oneshot";

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

233− PermissionsStartOnly = true;

234− User = data.user;

235− Group = data.group;

236− PrivateTmp = true;

237− };

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

239− preStart = ''

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

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

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

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

244− mkdir '${cpath}'

245− fi

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

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

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

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

250− '';

251− script = ''

252− cd '${cpath}'

253− set +e

254− simp_le ${escapeShellArgs cmdline}

255− EXITCODE=$?

256− set -e

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

258− exit "$EXITCODE"

259− '';

260− postStop = ''

261− cd '${cpath}'

262−

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

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

265−

266− ${data.preDelay}

267−

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

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

270− else

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

272− fi

273− '' else data.postRun}

274−

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

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

277− true

278− fi

279− '';

280−

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

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

283− };

284− delayService = {

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

286− path = with pkgs; [ rsync ];

287− serviceConfig = {

288− Type = "oneshot";

289− };

290− script = ''

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

292− '';

293− postStop = data.postRun;

294− };

295− selfsignedService = {

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

297− path = [ pkgs.openssl ];

298− preStart = ''

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

300− then

301− mkdir -p '${cpath}'

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

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

304− fi

305− '';

306− script =

307− ''

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

309−

310− # Create CA

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

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

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

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

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

316−

317− # Create key

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

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

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

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

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

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

324− -out $workdir/server.crt

325−

326− # Copy key to destination

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

328−

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

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

331−

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

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

334−

335− # Give key acme permissions

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

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

338− '';

339− serviceConfig = {

340− Type = "oneshot";

341− PermissionsStartOnly = true;

342− PrivateTmp = true;

343− User = data.user;

344− Group = data.group;

345− };

346− unitConfig = {

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

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

349− };

350− before = [

351− "acme-selfsigned-certificates.target"

352− ];

353− wantedBy = [

354− "acme-selfsigned-certificates.target"

355− ];

356− };

357− in (

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

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

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

361− );

362− servicesAttr = listToAttrs services;

363− injectServiceDep = {

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

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

366− };

367− in

368− servicesAttr //

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

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

371−

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

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

374− ({

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

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

377− timerConfig = {

378− OnCalendar = cfg.renewInterval;

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

380− Persistent = "yes";

381− AccuracySec = "5m";

382− RandomizedDelaySec = "1h";

383− };

384− })

385− );

386−

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

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

389− })

390−

391− ];

392−

393− meta = {

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

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

396− };

397−}

default.nix+4−18

@@ -34,10 +34,7 @@ let

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

35 haskellLib = pkgs.haskell.lib;

36 in {

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

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

38− jailbreak = true;

39− doCheck = false;

40− });

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

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

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

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

@@ -116,7 +113,7 @@ in rec {

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

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

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

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

118 obelisk = ghcObelisk;

115 obelisk = ghcObelisk;

119− obeliskEnvs = ghcObeliskEnvs;

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

120 command = ghcObelisk.obelisk-command;

117 command = ghcObelisk.obelisk-command;

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

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

122

119

@@ -125,10 +122,10 @@ in rec {

125 set -euo pipefail

122 set -euo pipefail

126

123

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

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

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

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

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

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

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

130 '';

128 '';

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

132 skeleton = pkgs.runCommand "skeleton" {

129 skeleton = pkgs.runCommand "skeleton" {

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

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

134 } ''

131 } ''

@@ -247,17 +244,6 @@ in rec {

247 imports = [

244 imports = [

248 (serverModules.mkBaseEc2 args)

245 (serverModules.mkBaseEc2 args)

249 (serverModules.mkObeliskApp args)

246 (serverModules.mkObeliskApp args)

250− ./acme.nix

251− ];

252− disabledModules = [

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

254− ];

255− nixpkgs.overlays = [

256− (self: super: let

257− nixos1909 = import (hackGet ./dep/nixpkgs-19.09) {};

258− in {

259− inherit (nixos1909) simp_le;

260− })

261 ];

247 ];

262 };

248 };

263 };

249 };

dep/nixpkgs-19.09/default.nix → dep/hnix/default.nixrenamed

The content is the same.

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/nixpkgs-19.09/github.jsondeleted−7

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

1−{

2− "owner": "nixos",

3− "repo": "nixpkgs-channels",

4− "branch": "nixos-19.09",

5− "rev": "ca9f709fd0b8535261234e6eb5d2020aaf1a2c61",

6− "sha256": "0z1qgmzx9dwbvwxf16f9m30y8lqy4zv4phl0mcyv7grfhj3s1abw"

7−}

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

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

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "develop",

4+ "branch": "master",

5− "rev": "aa8a9d1ac3d41ad51fbe04e575d4350da65cf3db",

5+ "rev": "72ca177da290dc5311c08683b8d167a205c9322e",

6− "sha256": "0hffy5rcfy6ay06ww3cxykqzp024jfcdg6w1yrmnf0h80sjfgdcm"

6+ "sha256": "06pqml1iqc5fawwsqb7wq77gh5v07bgb92hz8r1hf0ysr0abafcg"

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/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−1

@@ -8,7 +8,6 @@ import Control.Monad.Fail

8import Control.Monad.IO.Class

9import Data.Semigroup ((<>))

10import qualified Data.Text as T

11−import System.Process (proc)

13import Control.Monad.Catch (MonadMask)

12import Control.Monad.Catch (MonadMask)

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

@@ -9,17 +9,24 @@

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)

@@ -30,24 +37,50 @@ import Control.Lens (Prism', review)

30import qualified Data.ByteString as BS

37import qualified Data.ByteString as BS

31import qualified Data.ByteString.Char8 as BSC

38import qualified Data.ByteString.Char8 as BSC

32import Data.Function (fix)

39import Data.Function (fix)

40+import Data.Map (Map)

41+import qualified Data.Map as Map

33import Data.Monoid ((<>))

42import Data.Monoid ((<>))

34import Data.Text (Text)

43import Data.Text (Text)

35import qualified Data.Text as T

44import qualified Data.Text as T

36import qualified Data.Text.Encoding as T

45import qualified Data.Text.Encoding as T

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

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

47+import System.Environment (getEnvironment)

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

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

39import System.IO (Handle)

49import System.IO (Handle)

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

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

41import qualified System.IO.Streams as Streams

51import qualified System.IO.Streams as Streams

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

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

43−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)

44− waitForProcess)

45import qualified System.Process as Process

54import qualified System.Process as Process

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

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

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

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

49import 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+

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

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

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

53 deriving Show

86 deriving Show

@@ -62,7 +95,7 @@ instance AsProcessFailure ProcessFailure where

63readProcessAndLogStderr

96readProcessAndLogStderr

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

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

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

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

66readProcessAndLogStderr sev process = do

99readProcessAndLogStderr sev process = do

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

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

68 streamToLog =<< liftIO (streamHandle sev err)

101 streamToLog =<< liftIO (streamHandle sev err)

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

103

71readCreateProcessWithExitCode

104readCreateProcessWithExitCode

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

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

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

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

74−readCreateProcessWithExitCode process = do

107+readCreateProcessWithExitCode procSpec = do

108+ process <- mkCreateProcess procSpec

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

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

76 liftIO $ Process.readCreateProcessWithExitCode process ""

110 liftIO $ Process.readCreateProcessWithExitCode process ""

111

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

@@ -84,10 +118,10 @@ readCreateProcessWithExitCode process = do

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

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

85readProcessAndLogOutput

119readProcessAndLogOutput

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

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

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

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

88readProcessAndLogOutput (sev_out, sev_err) process = do

122readProcessAndLogOutput (sev_out, sev_err) process = do

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

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

90− { std_out = CreatePipe , std_err = CreatePipe }

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

125

92 -- TODO interleave stdout and stderr in log correctly

126 -- TODO interleave stdout and stderr in log correctly

93 streamToLog =<< liftIO (streamHandle sev_err err)

127 streamToLog =<< liftIO (streamHandle sev_err err)

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

130

97 liftIO (waitForProcess p) >>= \case

131 liftIO (waitForProcess p) >>= \case

98 ExitSuccess -> pure outText

132 ExitSuccess -> pure outText

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

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

100

134

101−-- | 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)

102-- with the corresponding severity.

136-- with the corresponding severity.

103--

137--

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

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

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

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

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

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

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

108callProcessAndLogOutput

142callProcessAndLogOutput

109−

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

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

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

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

112callProcessAndLogOutput (sev_out, sev_err) process =

145callProcessAndLogOutput (sev_out, sev_err) process =

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

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

114 stream <- liftIO $ join $ combineStream

147 stream <- liftIO $ join $ combineStream

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

118 where

151 where

119 combineStream s1 s2 = concurrentMerge [s1, s2]

152 combineStream s1 s2 = concurrentMerge [s1, s2]

120

153

121−-- | 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

122createProcess

155createProcess

123 :: (MonadIO m, CliLog m)

156 :: (MonadIO m, CliLog m)

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

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

125−createProcess p = do

158+createProcess procSpec = do

159+ p <- mkCreateProcess procSpec

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

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

127 liftIO $ Process.createProcess p

161 liftIO $ Process.createProcess p

128

162

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

130createProcess_

164createProcess_

131 :: (MonadIO m, CliLog m)

165 :: (MonadIO m, CliLog m)

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

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

133−createProcess_ name p = do

167+createProcess_ name procSpec = do

168+ p <- mkCreateProcess procSpec

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

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

135− 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) }

136

179

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

138callProcess

181callProcess

@@ -152,17 +195,17 @@ callCommand cmd = do

152

195

153withProcess

196withProcess

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

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

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

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

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

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

157 -- 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.

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

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

159− { std_out = CreatePipe , std_err = CreatePipe }

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

160

203

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

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

162

205

163 liftIO (waitForProcess p) >>= \case

206 liftIO (waitForProcess p) >>= \case

164 ExitSuccess -> return (out, err)

207 ExitSuccess -> return (out, err)

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

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

166

209

167-- 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.

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

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

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

179

222

180-- | Pretty print a 'CmdSpec'

223-- | Pretty print a 'CmdSpec'

181reconstructCommand :: Process.CmdSpec -> Text

224reconstructCommand :: Process.CmdSpec -> Text

225+reconstructCommand p = case p of

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

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

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

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

184 where

228 where

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

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

186 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/command/src/Obelisk/Command.hs+28−13

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

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

220 , help "Path to directory containing thunk data"

221 , help "Path to directory containing thunk data"

221 ]

222 ]

222

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+

223data ThunkCommand

242data ThunkCommand

224− = ThunkCommand_Update [FilePath] (Maybe String)

243+ = ThunkCommand_Update [FilePath] ThunkUpdateConfig

225 | ThunkCommand_Unpack [FilePath]

244 | ThunkCommand_Unpack [FilePath]

226− | ThunkCommand_Pack [FilePath] Bool

245+ | ThunkCommand_Pack [FilePath] ThunkPackConfig

227 deriving Show

246 deriving Show

228

247

229−forceFlag :: Parser Bool

230−forceFlag = switch $ long "force" <> short 'f' <> help "Force packing thunks even if there are branches not pushed upstream, uncommitted changes, stashes. This will cause changes that have not been pushed upstream to be lost; use with care."

231−

232thunkCommand :: Parser ThunkCommand

248thunkCommand :: Parser ThunkCommand

233thunkCommand = hsubparser $ mconcat

249thunkCommand = hsubparser $ mconcat

234− [ 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"

235 , 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"

236− , 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"

237 ]

253 ]

238

254

239data ShellOpts

255data ShellOpts

@@ -374,17 +390,16 @@ ob = \case

374 DeployCommand_Update -> deployUpdate "."

390 DeployCommand_Update -> deployUpdate "."

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

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

376 ObCommand_Run -> inNixShell' $ static run

392 ObCommand_Run -> inNixShell' $ static run

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

378 ObCommand_Thunk tc -> case tc of

393 ObCommand_Thunk tc -> case tc of

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

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

380− ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

395+ ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

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

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

382 ObCommand_Repl -> runRepl

397 ObCommand_Repl -> runRepl

383 ObCommand_Watch -> inNixShell' $ static runWatch

398 ObCommand_Watch -> inNixShell' $ static runWatch

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

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

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

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

386− ObCommand_Doc shell pkgs -> withProjectRoot "." $ \root ->

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

387− projectShell root False shell (Just $ haddockCommand pkgs)

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

388 ObCommand_Internal icmd -> case icmd of

403 ObCommand_Internal icmd -> case icmd of

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

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

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

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

lib/command/src/Obelisk/Command/Deploy.hs+10−11

@@ -25,17 +25,17 @@ import Nix.Pretty

25import Nix.String (principledMakeNixStringWithoutContext)

26import Nix.Value

27import System.Directory

28−import System.Environment (getEnvironment)

29import System.FilePath

28import System.FilePath

30import System.IO

29import System.IO

31import System.Posix.Files

30import System.Posix.Files

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

33import Text.URI (URI)

31import Text.URI (URI)

34import qualified Text.URI as URI

32import qualified Text.URI as URI

35import Text.URI.Lens

33import Text.URI.Lens

37import Obelisk.App (MonadObelisk)

35import Obelisk.App (MonadObelisk)

36+import Obelisk.CliApp (

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

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

38+ setCwd, setDelegateCtlc, setEnvOverride, withSpinner)

39import Obelisk.Command.Nix

40import Obelisk.Command.Project

41import Obelisk.Command.Thunk

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

82 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames

83 writeDeployConfig deployDir "enable_https" $ show enableHttps

84 writeDeployConfig deployDir "admin_email" adminEmail

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

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

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

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

88 setupObeliskImpl deployDir

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

107 Right (ThunkData_Packed ptr) -> return ptr

108 Right (ThunkData_Checkout _) -> do

109 checkGitCleanStatus srcPath True >>= \case

110− True -> packThunk False srcPath

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

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

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

113 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr

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

157 ]

158 isClean <- checkGitCleanStatus deployPath True

159 when (not isClean) $ do

160− withSpinner "Commiting changes to Git" $ do

160+ withSpinner "Committing changes to Git" $ do

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

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

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

@@ -165,12 +165,11 @@ deployPush deployPath getNixBuilders = do

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

166 where

167 callProcess' envMap cmd args = do

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

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

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

170 callProcessAndLogOutput (Notice, Notice) p

169 callProcessAndLogOutput (Notice, Notice) p

171

170

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

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

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

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

174

173

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

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

176keytoolToAndroidConfig conf =

175keytoolToAndroidConfig conf =

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

219 , _keytoolConfig_storepass = keyStorePassword

218 , _keytoolConfig_storepass = keyStorePassword

220 , _keytoolConfig_keypass = keyStorePassword

219 , _keytoolConfig_keypass = keyStorePassword

221 }

220 }

222− createKeystore root $ keyToolConf

221+ createKeystore root keyToolConf

223 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

222 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

224 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

223 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

225 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

224 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

@@ -275,7 +274,7 @@ instance ToJSON KeytoolConfig

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

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

276createKeystore root config = do

275createKeystore root config = do

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

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

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

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

279 where

278 where

280 keytoolCmd = processToShellString "keytool"

279 keytoolCmd = processToShellString "keytool"

281 [ "-genkeypair", "-noprompt"

280 [ "-genkeypair", "-noprompt"

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+5−10

@@ -30,7 +30,7 @@ import System.IO.Temp

30import System.IO.Unsafe (unsafePerformIO)

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

32import System.Posix.Files

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

33+import System.Process (waitForProcess)

34import System.Which (staticWhich)

36import GitHub.Data.GitData (Branch)

@@ -53,6 +53,7 @@ obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource

53 { _gitHubSource_owner = "obsidiansystems"

54 , _gitHubSource_repo = "obelisk"

55 , _gitHubSource_branch = Just branch

56+ , _gitHubSource_private = False

56 }

57 }

58data InitSource

59data InitSource

@@ -168,7 +169,7 @@ findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

168findProjectRoot target = do

169findProjectRoot target = do

169 myUid <- liftIO getRealUserID

170 myUid <- liftIO getRealUserID

170 targetStat <- liftIO $ getFileStatus target

171 targetStat <- liftIO $ getFileStatus target

171− umask <- liftIO $ getUmask

172+ umask <- liftIO getUmask

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

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

173 return result

174 return result

174

175

@@ -245,9 +246,9 @@ inImpureProjectShell shellName command = withProjectRoot "." $ \root ->

245projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

246projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

246projectShell root isPure shellName command = do

247projectShell root isPure shellName command = do

247 let nixPath = $(staticWhich "nix")

248 let nixPath = $(staticWhich "nix")

248− nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ proc nixPath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]

249+ nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $ proc nixPath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]

249 nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"

250 nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"

250− (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $

251+ (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setDelegateCtlc True $ setCwd (Just root) $ proc "nix-shell" $

251 [ "default.nix"] <>

252 [ "default.nix"] <>

252 ["--pure" | isPure] <>

253 ["--pure" | isPure] <>

253 [ "-A"

254 [ "-A"

@@ -262,9 +263,3 @@ projectShell root isPure shellName command = do

262 c

263 c

263 ]

264 ]

264 void $ liftIO $ waitForProcess ph

265 void $ liftIO $ waitForProcess ph

265−

266−setCtlc :: CreateProcess -> CreateProcess

267−setCtlc cfg = cfg { delegate_ctlc = True }

268−

269−setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess

270−setCwd fp cfg = cfg { cwd = fp }

lib/command/src/Obelisk/Command/Run.hs+11−10

@@ -31,7 +31,6 @@ import Language.Haskell.Extension

31import Network.Socket hiding (Debug)

32import System.Directory

33import System.FilePath

34−import System.Process (proc)

35import System.IO.Temp (withSystemTempDirectory)

34import System.IO.Temp (withSystemTempDirectory)

36import System.Which (staticWhich)

35import System.Which (staticWhich)

37import Data.ByteString (ByteString)

36import Data.ByteString (ByteString)

@@ -39,7 +38,7 @@ import Data.ByteString (ByteString)

39import Obelisk.App (MonadObelisk, ObeliskT)

38import Obelisk.App (MonadObelisk, ObeliskT)

40import Obelisk.CliApp

39import Obelisk.CliApp

41 ( CliT (..), HasCliConfig, Severity (..)

40 ( CliT (..), HasCliConfig, Severity (..)

42− , callCommand, failWith, getCliConfig, putLog

41+ , callCommand, failWith, getCliConfig, putLog, proc

43 , readProcessAndLogStderr, runCli)

42 , readProcessAndLogStderr, runCli)

44import Obelisk.Command.Project (inProjectShell, withProjectRoot)

43import Obelisk.Command.Project (inProjectShell, withProjectRoot)

@@ -133,11 +132,13 @@ parseCabalPackage dir name = do

133 return Nothing

132 return Nothing

134 Right (DecodeResult hpackPackage _ _ _) -> do

133 Right (DecodeResult hpackPackage _ _ _) -> do

135 return $ Just $ renderPackage [] hpackPackage

134 return $ Just $ renderPackage [] hpackPackage

135+ else do

136+ putLog Error $ T.pack "Found neither cabal nor hpack file"

136− else return Nothing

137+ return Nothing

137

138

138 fmap join $ forM mCabalContents $ \cabalContents -> do

139 fmap join $ forM mCabalContents $ \cabalContents -> do

139 let (warnings, result) = runParseResult $ parseGenericPackageDescription $

140 let (warnings, result) = runParseResult $ parseGenericPackageDescription $

140− toUTF8BS $ cabalContents

141+ toUTF8BS cabalContents

141 mapM_ (putLog Warning) $ fmap (T.pack . show) warnings

142 mapM_ (putLog Warning) $ fmap (T.pack . show) warnings

142 case result of

143 case result of

143 Right gpkg -> do

144 Right gpkg -> do

@@ -167,7 +168,7 @@ withUTF8FileContentsM fp f = do

167withGhciScript

168withGhciScript

168 :: MonadObelisk m

169 :: MonadObelisk m

169 => [(FilePath, Maybe String)] -- ^ List of packages to load into ghci

170 => [(FilePath, Maybe String)] -- ^ List of packages to load into ghci

170− -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporory .ghci

171+ -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci

171 -> m ()

172 -> m ()

172withGhciScript pkgs f = do

173withGhciScript pkgs f = do

173 (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \(dir, name) -> do

174 (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \(dir, name) -> do

@@ -187,16 +188,16 @@ withGhciScript pkgs f = do

187 language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs

188 language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs

188 extensionsLine = if extensions == mempty

189 extensionsLine = if extensions == mempty

189 then ""

190 then ""

190− else ":set " <> intercalate " " ((("-X" <>) . prettyShow) <$> extensions)

191+ else ":set " <> unwords (("-X" <>) . prettyShow <$> extensions)

191 ghcOptions = concat $ mapMaybe (\case (GHC, xs) -> Just xs; _ -> Nothing) $

192 ghcOptions = concat $ mapMaybe (\case (GHC, xs) -> Just xs; _ -> Nothing) $

192 packageInfos >>= _cabalPackageInfo_compilerOptions

193 packageInfos >>= _cabalPackageInfo_compilerOptions

193− dotGhci = unlines $

194+ dotGhci = unlines

194 [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)

195 [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)

195 , case ghcOptions of

196 , case ghcOptions of

196 [] -> ""

197 [] -> ""

197− xs -> ":set " <> intercalate " " xs

198+ xs -> ":set " <> unwords xs

198 , extensionsLine

199 , extensionsLine

199− , ":set " <> intercalate " " (("-X" <>) . prettyShow <$> language)

200+ , ":set " <> unwords (("-X" <>) . prettyShow <$> language)

200 , ":load Backend Frontend"

201 , ":load Backend Frontend"

201 , "import Obelisk.Run"

202 , "import Obelisk.Run"

202 , "import qualified Frontend"

203 , "import qualified Frontend"

@@ -256,4 +257,4 @@ getFreePort = liftIO $ withSocketsDo $ do

256 open addr = do

257 open addr = do

257 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)

258 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)

258 bind sock (addrAddress addr)

259 bind sock (addrAddress addr)

259− return sock

260+ return sock

lib/command/src/Obelisk/Command/Thunk.hs+177−99

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

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

@@ -155,20 +185,20 @@ commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

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

@@ -570,9 +637,9 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

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

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

@@ -622,24 +689,32 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with

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+22−13

@@ -23,7 +23,6 @@ import Data.Void (Void)

23import System.Directory (canonicalizePath)

24import System.Environment (getExecutablePath)

25import System.Exit (ExitCode)

26−import qualified System.Process as P

27import Text.Megaparsec as MP

26import Text.Megaparsec as MP

28import Text.Megaparsec.Char as MP

27import Text.Megaparsec.Char as MP

@@ -61,20 +60,30 @@ initGit repo = do

61 git ["add", "."]

60 git ["add", "."]

62 git ["commit", "-m", "Initial commit."]

61 git ["commit", "-m", "Initial commit."]

64−gitProcNoRepo :: [String] -> P.CreateProcess

63+gitProcNoRepo :: [String] -> ProcessSpec

65−gitProcNoRepo = P.proc "git"

64+gitProcNoRepo args = setEnvOverride (M.singleton "GIT_TERMINAL_PROMPT" "0" <>) $ proc "git" args

67−gitProc :: FilePath -> [String] -> P.CreateProcess

66+gitProc :: FilePath -> [String] -> ProcessSpec

68gitProc repo = gitProcNoRepo . runGitInDir

67gitProc repo = gitProcNoRepo . runGitInDir

69 where

68 where

70 runGitInDir args' = case filter (not . null) args' of

69 runGitInDir args' = case filter (not . null) args' of

71 args@("clone":_) -> args <> [repo]

70 args@("clone":_) -> args <> [repo]

72 args -> ["-C", repo] <> args

71 args -> ["-C", repo] <> args

73+isolateGitProc :: ProcessSpec -> ProcessSpec

74+isolateGitProc = setEnvOverride (overrides <>)

75+ where

76+ overrides = M.fromList

77+ [ ("HOME", "/dev/null")

78+ , ("GIT_CONFIG_NOSYSTEM", "1")

79+ , ("GIT_TERMINAL_PROMPT", "0")

80+ , ("GIT_SSH_COMMAND", "ssh -o PreferredAuthentications=password -o PubkeyAuthentication=no -o GSSAPIAuthentication=no")

81+ ]

82+

74−-- | Recursively copy a directory using `cp -a`

83+-- | Recursively copy a directory using `cp -a` -- TODO: Should use -rT instead of -a

75−copyDir :: FilePath -> FilePath -> P.CreateProcess

84+copyDir :: FilePath -> FilePath -> ProcessSpec

76copyDir src dest =

85copyDir src dest =

77− (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }

86+ 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

88readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

80readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

89readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

@@ -87,15 +96,15 @@ processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

87 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

96 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

89-- | A simpler wrapper for CliApp's most used process function with sensible defaults.

98-- | A simpler wrapper for CliApp's most used process function with sensible defaults.

90−runProc :: MonadObelisk m => P.CreateProcess -> m ()

99+runProc :: MonadObelisk m => ProcessSpec -> m ()

91runProc = callProcessAndLogOutput (Notice, Error)

100runProc = callProcessAndLogOutput (Notice, Error)

101

93-- | Like runProc, but all output goes to Debug logging level

102-- | Like runProc, but all output goes to Debug logging level

94−runProcSilently :: MonadObelisk m => P.CreateProcess -> m ()

103+runProcSilently :: MonadObelisk m => ProcessSpec -> m ()

95runProcSilently = callProcessAndLogOutput (Debug, Debug)

104runProcSilently = callProcessAndLogOutput (Debug, Debug)

105

97-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.

106-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.

98−readProc :: MonadObelisk m => P.CreateProcess -> m Text

107+readProc :: MonadObelisk m => ProcessSpec -> m Text

99readProc = readProcessAndLogOutput (Debug, Error)

108readProc = readProcessAndLogOutput (Debug, Error)

100

109

101tshow :: Show a => a -> Text

110tshow :: Show a => a -> Text

@@ -129,13 +138,13 @@ gitLsRemote repository mRef mBranch = do

129 (exitCode, out, _err) <- case mBranch of

138 (exitCode, out, _err) <- case mBranch of

130 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

139 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

131 ["ls-remote", "--exit-code", "--symref", repository]

140 ["ls-remote", "--exit-code", "--symref", repository]

132− ++ (maybeToList $ T.unpack . showGitRef <$> mRef)

141+ ++ maybeToList (T.unpack . showGitRef <$> mRef)

133− Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo $

142+ Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo

134 ["ls-remote", "--exit-code", repository, branchName]

143 ["ls-remote", "--exit-code", repository, branchName]

135 let t = T.pack out

144 let t = T.pack out

136 maps <- case MP.runParser parseLsRemote "" t of

145 maps <- case MP.runParser parseLsRemote "" t of

137 Left err -> failWith $ T.pack $ MP.errorBundlePretty err

146 Left err -> failWith $ T.pack $ MP.errorBundlePretty err

138− Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table

147+ Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers table

139 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

148 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

140 pure (exitCode, maps)

149 pure (exitCode, maps)

141

150

lib/command/src/Obelisk/Command/VmBuilder.hs−1

@@ -18,7 +18,6 @@ import System.Directory (createDirectoryIfMissing)

18import System.Exit (ExitCode(..))

19import System.FilePath ((<.>), (</>))

20import qualified System.Info

21−import System.Process (proc)

23import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

22import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

24import Obelisk.CliApp

23import Obelisk.CliApp

lib/executable-config/lookup/obelisk-executable-config-lookup.cabal+1−1

@@ -27,7 +27,7 @@ library

27 build-depends: directory

29 build-depends:

30− base,

30+ base,

31 base64-bytestring,

32 bytestring,

33 containers,

lib/route/src/Obelisk/Route.hs+1−1

@@ -881,7 +881,7 @@ instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where

881 gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y

882

883instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where

884− universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]

884+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]

885 ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]

886

887-- | Build the typical top level application route encoder from a route for handling 404's,

lib/run/src/Obelisk/Run.hs+1−1

@@ -129,7 +129,7 @@ runWidget conf configs frontend validFullEncoder = do

129 putStrLn $ "Frontend running on " <> T.unpack (URI.render uri)

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

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

lib/selftest/src/Obelisk/SelfTest.hs+39−23

@@ -3,6 +3,7 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE ViewPatterns #-}

6module Obelisk.SelfTest where

7module Obelisk.SelfTest where

8import Control.Exception (bracket, throw)

9import Control.Exception (bracket, throw)

@@ -24,7 +25,7 @@ import Shelly

24import System.Directory (withCurrentDirectory, getDirectoryContents)

25import System.Directory (withCurrentDirectory, getDirectoryContents)

25import System.Environment

26import System.Environment

26import System.Exit (ExitCode (..))

27import System.Exit (ExitCode (..))

27−import System.Info

28+import qualified System.Info

28import System.IO (Handle, hClose)

29import System.IO (Handle, hClose)

29import System.IO.Temp

30import System.IO.Temp

30import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)

31import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)

@@ -75,24 +76,38 @@ main = do

75 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

76 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

76 let verbosity = bool silently verbosely isVerbose

77 let verbosity = bool silently verbosely isVerbose

77 nixBuild args = run "nix-build" ("--no-out-link" : args)

78 nixBuild args = run "nix-build" ("--no-out-link" : args)

78− obeliskImpl <- fromString <$> getEnv "OBELISK_IMPL"

79+ obeliskImplRaw <- fromString <$> getEnv "OBELISK_IMPL"

80+ let

81+ withObeliskImpl f =

82+ withSystemTempDirectory "obelisk-impl-copy" $ \(fromString -> obeliskImpl) -> do

83+ void . shellyOb verbosity $ chdir obeliskImpl $ do

84+ user <- T.strip <$> run "whoami" []

85+ run_ "cp" ["-rT", toTextIgnore obeliskImplRaw, toTextIgnore obeliskImpl]

86+ run_ "chown" ["-R", user, toTextIgnore obeliskImpl]

87+ run_ "chmod" ["-R", "g-rw,o-rw", toTextIgnore obeliskImpl]

88+

89+ withSystemTempDirectory "init Cache λ" $ \initCache -> do

90+ -- Setup the ob init cache

91+ void . shellyOb verbosity $ chdir (fromString initCache) $ do

92+ run_ "ob" ["init", "--symlink", toTextIgnore obeliskImpl]

93+ run_ "git" ["init"]

94+

95+ f obeliskImpl initCache

96+

79 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

97 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

80 [p0, p1, p2, p3] <- liftIO $ getFreePorts 4

98 [p0, p1, p2, p3] <- liftIO $ getFreePorts 4

81− withSystemTempDirectory "initCache" $ \initCache -> do

99+

82− -- Setup the ob init cache

100+ withObeliskImpl $ \obeliskImpl initCache ->

83− void . shellyOb verbosity $ chdir (fromString initCache) $ do

84− run_ "ob" ["init"]

85− run_ "git" ["init"]

86 hspec $ parallel $ do

101 hspec $ parallel $ do

87 let shelly_ = void . shellyOb verbosity

102 let shelly_ = void . shellyOb verbosity

103

89 inTmp :: (Shelly.FilePath -> Sh a) -> IO ()

104 inTmp :: (Shelly.FilePath -> Sh a) -> IO ()

90 inTmp f = withTmp (chdir <*> f)

105 inTmp f = withTmp (chdir <*> f)

106

92− withTmp f = shelly_ . withSystemTempDirectory "test" $ f . fromString

107+ withTmp f = shelly_ . withSystemTempDirectory "test λ" $ f . fromString

108

94 inTmpObInit f = inTmp $ \dir -> do

109 inTmpObInit f = inTmp $ \dir -> do

95− run_ "cp" ["-a", fromString $ initCache <> "/.", toTextIgnore dir]

110+ run_ "cp" ["-rT", fromString initCache, toTextIgnore dir]

96 f dir

111 f dir

112

98 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b

113 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b

@@ -115,9 +130,9 @@ main = do

115 describe "ob init" $ parallel $ do

130 describe "ob init" $ parallel $ do

116 it "works with default impl" $ inTmp $ \_ -> run "ob" ["init"]

131 it "works with default impl" $ inTmp $ \_ -> run "ob" ["init"]

117 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

132 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

118− it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]

133+ it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", toTextIgnore obeliskImpl]

119− it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init" $ \dir -> do

134+ it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init λ" $ \dir -> do

120− let p force = (proc "ob" $ "--no-handoff" : "init" : ["--force"|force]) { cwd = Just dir }

135+ let p force = (System.Process.proc "ob" $ "--no-handoff" : "init" : ["--force"|force]) { cwd = Just dir }

121 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

136 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

122 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

137 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

123 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

138 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

@@ -139,17 +154,17 @@ main = do

139 it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir p2 p3 (Just "frontend") httpManager

154 it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir p2 p3 (Just "frontend") httpManager

140

155

141 describe "obelisk project" $ parallel $ do

156 describe "obelisk project" $ parallel $ do

142− it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , obeliskImpl]

157+ it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskImpl]

143− it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", obeliskImpl]

158+ it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", toTextIgnore obeliskImpl]

144− it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", obeliskImpl]

159+ it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", toTextIgnore obeliskImpl]

145− it "can build everything" $ inTmpObInit $ \_ -> nixBuild [obeliskImpl]

160+ it "can build everything" $ inTmpObInit $ \_ -> nixBuild [toTextIgnore obeliskImpl]

146

161

147 describe "blank initialized project" $ parallel $ do

162 describe "blank initialized project" $ parallel $ do

148

163

149 it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]

164 it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]

150 it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]

165 it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]

151

166

152− if os == "darwin"

167+ if System.Info.os == "darwin"

153 then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

168 then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

154 else it "can build android after accepting license" $ inTmpObInit $ \dir -> do

169 else it "can build android after accepting license" $ inTmpObInit $ \dir -> do

155 let defaultNixPath = dir </> ("default.nix" :: Shelly.FilePath)

170 let defaultNixPath = dir </> ("default.nix" :: Shelly.FilePath)

@@ -162,12 +177,13 @@ main = do

162

177

163 forM_ ["ghc", "ghcjs"] $ \compiler -> do

178 forM_ ["ghc", "ghcjs"] $ \compiler -> do

164 let

179 let

165− shell = "shells." <> compiler

180+ shellName = "shells." <> compiler

166− inShell cmd' = run "nix-shell" ["default.nix", "-A", fromString shell, "--run", cmd']

181+ inShell cmd' = run "nix-shell" ["default.nix", "-A", fromString shellName, "--run", cmd']

167− it ("can enter " <> shell) $ inTmpObInit $ \_ -> inShell "exit"

182+ it ("can enter " <> shellName) $ inTmpObInit $ \_ -> inShell "exit"

168− it ("can build in " <> shell) $ inTmpObInit $ \_ -> inShell $ "cabal new-build --" <> fromString compiler <> " all"

183+ it ("can build in " <> shellName) $ inTmpObInit $ \_ -> inShell $ "cabal new-build --" <> fromString compiler <> " all"

169

184

170 it "has idempotent thunk update" $ inTmpObInit $ \_ -> do

185 it "has idempotent thunk update" $ inTmpObInit $ \_ -> do

186+ _ <- pack

171 u <- update

187 u <- update

172 uu <- update

188 uu <- update

173 assertRevEQ u uu

189 assertRevEQ u uu

@@ -175,6 +191,7 @@ main = do

175 describe "ob thunk pack/unpack" $ parallel $ do

191 describe "ob thunk pack/unpack" $ parallel $ do

176 it "has thunk pack and unpack inverses" $ inTmpObInit $ \_ -> do

192 it "has thunk pack and unpack inverses" $ inTmpObInit $ \_ -> do

177

193

194+ _ <- pack

178 e <- commitAll

195 e <- commitAll

179 eu <- unpack

196 eu <- unpack

180 eup <- pack

197 eup <- pack

@@ -212,7 +229,6 @@ main = do

212 testThunkPack $ fromText repo

229 testThunkPack $ fromText repo

213

230

214 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

231 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

215− void unpack

216 testThunkPack (dir </> thunk)

232 testThunkPack (dir </> thunk)

217

233

218 describe "ob thunk update --branch" $ parallel $ do

234 describe "ob thunk update --branch" $ parallel $ do

@@ -237,7 +253,7 @@ testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePat

237testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do

253testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do

238 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison

254 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison

239 writefile "config/common/route" $ uri p0

255 writefile "config/common/route" $ uri p0

240− maybe id chdir mdir $ runHandle "ob" ["run"] $ \stdout -> do

256+ maybe id chdir mdir $ runHandle "ob" ["run", "-v"] $ \stdout -> do

241 firstUri <- handleObRunStdout httpManager stdout

257 firstUri <- handleObRunStdout httpManager stdout

242 let newUri = uri p1

258 let newUri = uri p1

243 when (firstUri == newUri) $ errorExit $

259 when (firstUri == newUri) $ errorExit $

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

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/common/common.cabal−3

@@ -9,9 +9,6 @@ library

9 , obelisk-route

10 , mtl

11 , text

12− default-extensions:

13− TypeFamilies

14− PolyKinds

15 exposed-modules:

12 exposed-modules:

16 Common.Api

13 Common.Api

17 Common.Route

14 Common.Route

skeleton/common/src/Common/Route.hs+1

@@ -8,6 +8,7 @@

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeFamilies #-}

11module Common.Route where

12module Common.Route where

13{- -- You will probably want these imports for composing Encoders.

14{- -- You will probably want these imports for composing Encoders.

skeleton/frontend/src/Frontend.hs+9−3

@@ -1,24 +1,30 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE TypeApplications #-}

4module Frontend where

5module Frontend where

6import qualified Data.Text as T

7import qualified Data.Text as T

7import qualified Data.Text.Encoding as T

8import qualified Data.Text.Encoding as T

8import Obelisk.Frontend

10import Obelisk.Frontend

9import Obelisk.Configs

11import Obelisk.Configs

10import Obelisk.Route

12import Obelisk.Route

13+import Obelisk.Generated.Static

14+

11import Reflex.Dom.Core

15import Reflex.Dom.Core

13import Common.Api

17import Common.Api

14import Common.Route

18import Common.Route

15−import Obelisk.Generated.Static

19+

17frontend :: Frontend (R FrontendRoute)

21frontend :: Frontend (R FrontendRoute)

18frontend = Frontend

22frontend = Frontend

23+ { _frontend_head = do

19− { _frontend_head = el "title" $ text "Obelisk Minimal Example"

24+ el "title" $ text "Obelisk Minimal Example"

25+ elAttr "link" ("href" =: static @"main.css" <> "type" =: "text/css" <> "rel" =: "stylesheet") blank

20 , _frontend_body = do

26 , _frontend_body = do

21− text "Welcome to Obelisk!"

27+ el "h1" $ text "Welcome to Obelisk!"

22 el "p" $ text $ T.pack commonStuff

28 el "p" $ text $ T.pack commonStuff

23 elAttr "img" ("src" =: static @"obelisk.jpg") blank

29 elAttr "img" ("src" =: static @"obelisk.jpg") blank

24 el "div" $ do

30 el "div" $ do

skeleton/static/main.cssnew file+3

@@ -0,0 +1,3 @@

1+p {

2+ color: red;

3+}