1dbc012 · obelisk · git.iko.soy

git.iko.soy/obelisk

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

commit1dbc012fc3c68b662a0d1c9445890a7335f5ba97 authorElliot Cameron <eacameron@gmail.com> dateFri 3 Jan 2020, 17:41 (7 years ago) parentaa7448b 3eb6f2c

33 files changed+507−669

compare with master

unifiedsplit

.gitignore+1

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

22**/.cabal-sandbox

33**/cabal.sandbox.config

44result

5+result-*

56*.o

67*.hi

78TAGS

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

33This 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+

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

616

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

README.md+1−1

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

152152

153153### Running over https

154154

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.

156156

157157Since 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.

158158

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

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

3535 haskellLib = pkgs.haskell.lib;

3636 in {

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

38− jailbreak = true;

39− doCheck = false;

40− });

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

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

4239

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

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

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

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

118115 obelisk = ghcObelisk;

119− obeliskEnvs = ghcObeliskEnvs;

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

120117 command = ghcObelisk.obelisk-command;

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

122119

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

125122 set -euo pipefail

126123

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

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

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

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

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

130128 '';

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

132129 skeleton = pkgs.runCommand "skeleton" {

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

134131 } ''

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

247244 imports = [

248245 (serverModules.mkBaseEc2 args)

249246 (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− })

261247 ];

262248 };

263249 };

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

11{

22 "owner": "reflex-frp",

33 "repo": "reflex-platform",

4− "branch": "develop",

5− "rev": "aa8a9d1ac3d41ad51fbe04e575d4350da65cf3db",

6− "sha256": "0hffy5rcfy6ay06ww3cxykqzp024jfcdg6w1yrmnf0h80sjfgdcm"

4+ "branch": "master",

5+ "rev": "72ca177da290dc5311c08683b8d167a205c9322e",

6+ "sha256": "06pqml1iqc5fawwsqb7wq77gh5v07bgb92hz8r1hf0ysr0abafcg"

77}

lib/asset/README.md+10−10

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

11## obelisk-asset

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

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

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

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

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

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

77```

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

1010```

1111

1212The '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',

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

1515

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

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

1818```

19−myAssets = assets.mkAssets ./static;

19+myAssets = assets.mkAssets ./static;

2020```

2121

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

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

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

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

26−that holds hashed static assets.

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

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

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

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

26+that holds hashed static assets.

2727```bash

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

2929```

lib/cliapp/obelisk-cliapp.cabal+1

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

1010 ansi-terminal

1111 , base

1212 , bytestring

13+ , containers

1314 , exceptions

1415 , io-streams

1516 , lens

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

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

3333 , Severity (..)

3434

3535 -- .Process

36− , ProcessFailure (..)

3736 , AsProcessFailure (..)

38− , readProcessAndLogStderr

39− , readProcessAndLogOutput

40− , readCreateProcessWithExitCode

37+ , ProcessFailure (..)

38+ , ProcessSpec (..)

39+ , callCommand

40+ , callProcess

4141 , callProcessAndLogOutput

4242 , createProcess_

43− , callProcess

44− , callCommand

43+ , overCreateProcess

44+ , proc

45+ , readCreateProcessWithExitCode

46+ , readProcessAndLogOutput

47+ , readProcessAndLogStderr

4548 , reconstructCommand

49+ , setCwd

50+ , setDelegateCtlc

51+ , setEnvOverride

52+ , shell

4653 ) where

4754

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

lib/cliapp/src/Obelisk/CliApp/Demo.hs−1

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

88import Control.Monad.IO.Class

99import Data.Semigroup ((<>))

1010import qualified Data.Text as T

11−import System.Process (proc)

1211

1312import Control.Monad.Catch (MonadMask)

1413

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

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

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

1010-- and is thus spinner friendly.

1111module Obelisk.CliApp.Process

12− ( ProcessFailure (..)

13− , AsProcessFailure (..)

14− , readProcessAndLogStderr

15− , readProcessAndLogOutput

16− , readCreateProcessWithExitCode

12+ ( AsProcessFailure (..)

13+ , ProcessFailure (..)

14+ , ProcessSpec (..)

15+ , callCommand

16+ , callProcess

1717 , callProcessAndLogOutput

1818 , createProcess

1919 , createProcess_

20− , callProcess

21− , callCommand

20+ , overCreateProcess

21+ , proc

22+ , readCreateProcessWithExitCode

23+ , readProcessAndLogOutput

24+ , readProcessAndLogStderr

2225 , reconstructCommand

26+ , setCwd

27+ , setDelegateCtlc

28+ , setEnvOverride

29+ , shell

2330 ) where

2431

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

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

3037import qualified Data.ByteString as BS

3138import qualified Data.ByteString.Char8 as BSC

3239import Data.Function (fix)

40+import Data.Map (Map)

41+import qualified Data.Map as Map

3342import Data.Monoid ((<>))

3443import Data.Text (Text)

3544import qualified Data.Text as T

3645import qualified Data.Text.Encoding as T

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

47+import System.Environment (getEnvironment)

3848import System.Exit (ExitCode (..))

3949import System.IO (Handle)

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

4151import qualified System.IO.Streams as Streams

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

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

44− waitForProcess)

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

4554import qualified System.Process as Process

4655

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

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

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

5059

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+

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

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

5386 deriving Show

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

6295

6396readProcessAndLogStderr

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

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

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

6699readProcessAndLogStderr sev process = do

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

68101 streamToLog =<< liftIO (streamHandle sev err)

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

70103

71104readCreateProcessWithExitCode

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

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

74−readCreateProcessWithExitCode process = do

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

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

107+readCreateProcessWithExitCode procSpec = do

108+ process <- mkCreateProcess procSpec

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

76110 liftIO $ Process.readCreateProcessWithExitCode process ""

77111

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

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

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

85119readProcessAndLogOutput

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

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

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

88122readProcessAndLogOutput (sev_out, sev_err) process = do

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

90− { std_out = CreatePipe , std_err = CreatePipe }

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

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

91125

92126 -- TODO interleave stdout and stderr in log correctly

93127 streamToLog =<< liftIO (streamHandle sev_err err)

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

96130

97131 liftIO (waitForProcess p) >>= \case

98132 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

100134

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)

102136-- with the corresponding severity.

103137--

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

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

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

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

108142callProcessAndLogOutput

109−

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

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

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

112145callProcessAndLogOutput (sev_out, sev_err) process =

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

114147 stream <- liftIO $ join $ combineStream

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

118151 where

119152 combineStream s1 s2 = concurrentMerge [s1, s2]

120153

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

122155createProcess

123156 :: (MonadIO m, CliLog m)

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

125−createProcess p = do

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

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

158+createProcess procSpec = do

159+ p <- mkCreateProcess procSpec

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

127161 liftIO $ Process.createProcess p

128162

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

130164createProcess_

131165 :: (MonadIO m, CliLog m)

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

133−createProcess_ name p = do

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

135− liftIO $ Process.createProcess p

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

167+createProcess_ name procSpec = do

168+ p <- mkCreateProcess procSpec

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

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

136179

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

138181callProcess

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

152195

153196withProcess

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

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

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

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

159− { std_out = CreatePipe , std_err = CreatePipe }

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

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

160203

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

162205

163206 liftIO (waitForProcess p) >>= \case

164207 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

166209

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

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

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

179222

180223-- | Pretty print a 'CmdSpec'

181224reconstructCommand :: Process.CmdSpec -> Text

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

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

225+reconstructCommand p = case p of

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

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

184228 where

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

186230 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

1313import Data.Bool (bool)

1414import qualified Data.ByteString.Base16 as Base16

1515import qualified Data.ByteString.Lazy as LBS

16+import Data.Foldable (for_)

1617import Data.List

1718import Data.Maybe (catMaybes)

1819import qualified Data.Text as T

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

220221 , help "Path to directory containing thunk data"

221222 ]

222223

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+

223242data ThunkCommand

224− = ThunkCommand_Update [FilePath] (Maybe String)

243+ = ThunkCommand_Update [FilePath] ThunkUpdateConfig

225244 | ThunkCommand_Unpack [FilePath]

226− | ThunkCommand_Pack [FilePath] Bool

245+ | ThunkCommand_Pack [FilePath] ThunkPackConfig

227246 deriving Show

228247

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−

232248thunkCommand :: Parser ThunkCommand

233249thunkCommand = 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"

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

237253 ]

238254

239255data ShellOpts

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

374390 DeployCommand_Update -> deployUpdate "."

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

376392 ObCommand_Run -> inNixShell' $ static run

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

378393 ObCommand_Thunk tc -> case tc of

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

380− ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

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

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

395+ ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

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

382397 ObCommand_Repl -> runRepl

383398 ObCommand_Watch -> inNixShell' $ static runWatch

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

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

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

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

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

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

388403 ObCommand_Internal icmd -> case icmd of

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

390405 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

2525import Nix.String (principledMakeNixStringWithoutContext)

2626import Nix.Value

2727import System.Directory

28−import System.Environment (getEnvironment)

2928import System.FilePath

3029import System.IO

3130import System.Posix.Files

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

3331import Text.URI (URI)

3432import qualified Text.URI as URI

3533import Text.URI.Lens

3634

3735import Obelisk.App (MonadObelisk)

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

36+import Obelisk.CliApp (

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

38+ setCwd, setDelegateCtlc, setEnvOverride, withSpinner)

3939import Obelisk.Command.Nix

4040import Obelisk.Command.Project

4141import Obelisk.Command.Thunk

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

8282 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames

8383 writeDeployConfig deployDir "enable_https" $ show enableHttps

8484 writeDeployConfig deployDir "admin_email" adminEmail

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

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

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

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

8888 setupObeliskImpl deployDir

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

107107 Right (ThunkData_Packed ptr) -> return ptr

108108 Right (ThunkData_Checkout _) -> do

109109 checkGitCleanStatus srcPath True >>= \case

110− True -> packThunk False srcPath

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

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

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

113113 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr

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

157157 ]

158158 isClean <- checkGitCleanStatus deployPath True

159159 when (not isClean) $ do

160− withSpinner "Commiting changes to Git" $ do

160+ withSpinner "Committing changes to Git" $ do

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

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

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

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

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

166166 where

167167 callProcess' envMap cmd args = do

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

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

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

170169 callProcessAndLogOutput (Notice, Notice) p

171170

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

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

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

174173

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

176175keytoolToAndroidConfig conf =

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

219218 , _keytoolConfig_storepass = keyStorePassword

220219 , _keytoolConfig_keypass = keyStorePassword

221220 }

222− createKeystore root $ keyToolConf

221+ createKeystore root keyToolConf

223222 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

224223 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

225224 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

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

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

276275createKeystore root config = do

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

279278 where

280279 keytoolCmd = processToShellString "keytool"

281280 [ "-genkeypair", "-noprompt"

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

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

3737import Data.Maybe

3838import Data.Monoid ((<>))

3939import qualified Data.Text as T

40−import System.Process (proc)

4140

4241import Obelisk.App (MonadObelisk)

4342import Obelisk.CliApp

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

160159

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

162161nixCmd 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

164163 -- Remove final newline that Nix appends

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

166165 pure $ T.unpack outPath

lib/command/src/Obelisk/Command/Project.hs+5−10

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

3030import System.IO.Unsafe (unsafePerformIO)

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

3232import System.Posix.Files

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

33+import System.Process (waitForProcess)

3434import System.Which (staticWhich)

3535

3636import GitHub.Data.GitData (Branch)

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

5353 { _gitHubSource_owner = "obsidiansystems"

5454 , _gitHubSource_repo = "obelisk"

5555 , _gitHubSource_branch = Just branch

56+ , _gitHubSource_private = False

5657 }

5758

5859data InitSource

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

168169findProjectRoot target = do

169170 myUid <- liftIO getRealUserID

170171 targetStat <- liftIO $ getFileStatus target

171− umask <- liftIO $ getUmask

172+ umask <- liftIO getUmask

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

173174 return result

174175

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

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

246247projectShell root isPure shellName command = do

247248 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"]

249250 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" $

251252 [ "default.nix"] <>

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

253254 [ "-A"

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

262263 c

263264 ]

264265 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

3131import Network.Socket hiding (Debug)

3232import System.Directory

3333import System.FilePath

34−import System.Process (proc)

3534import System.IO.Temp (withSystemTempDirectory)

3635import System.Which (staticWhich)

3736import Data.ByteString (ByteString)

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

3938import Obelisk.App (MonadObelisk, ObeliskT)

4039import Obelisk.CliApp

4140 ( CliT (..), HasCliConfig, Severity (..)

42− , callCommand, failWith, getCliConfig, putLog

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

4342 , readProcessAndLogStderr, runCli)

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

4544

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

133132 return Nothing

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

135134 return $ Just $ renderPackage [] hpackPackage

136− else return Nothing

135+ else do

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

137+ return Nothing

137138

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

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

140− toUTF8BS $ cabalContents

141+ toUTF8BS cabalContents

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

142143 case result of

143144 Right gpkg -> do

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

167168withGhciScript

168169 :: MonadObelisk m

169170 => [(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

171172 -> m ()

172173withGhciScript pkgs f = do

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

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

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

188189 extensionsLine = if extensions == mempty

189190 then ""

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

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

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

192193 packageInfos >>= _cabalPackageInfo_compilerOptions

193− dotGhci = unlines $

194+ dotGhci = unlines

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

195196 , case ghcOptions of

196197 [] -> ""

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

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

198199 , extensionsLine

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

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

200201 , ":load Backend Frontend"

201202 , "import Obelisk.Run"

202203 , "import qualified Frontend"

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

256257 open addr = do

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

258259 bind sock (addrAddress addr)

259− return sock

260+ return sock

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

@@ -8,25 +8,30 @@

88{-# LANGUAGE ScopedTypeVariables #-}

99{-# LANGUAGE TypeApplications #-}

1010module Obelisk.Command.Thunk

11− ( ThunkPtr (..)

11+ ( GitHubSource (..)

12+ , GitUri (..)

13+ , ReadThunkError (..)

14+ , ThunkConfig (..)

15+ , ThunkData (..)

16+ , ThunkPackConfig (..)

17+ , ThunkPtr (..)

1218 , ThunkRev (..)

1319 , ThunkSource (..)

14− , ThunkData (..)

15− , ReadThunkError (..)

16− , GitHubSource (..)

17− , getThunkGitBranch

18− , getLatestRev

19− , updateThunkToLatest

20+ , ThunkUpdateConfig (..)

2021 , createThunk

2122 , createThunkWithLatest

23+ , getLatestRev

24+ , getThunkGitBranch

25+ , getThunkPtr

26+ , gitUriToText

2227 , nixBuildAttrWithCache

2328 , nixBuildThunkAttrWithCache

24− , unpackThunk

2529 , packThunk

30+ , parseGitUri

2631 , readThunk

32+ , unpackThunk

2733 , updateThunk

28− , getThunkPtr

29− , parseGitUri

34+ , updateThunkToLatest

3035 , uriThunkPtr

3136 ) where

3237

@@ -68,8 +73,7 @@ import System.FilePath

6873import System.IO.Error

6974import System.IO.Temp

7075import System.Posix (getSymbolicLinkStatus, modificationTime)

71−import System.Process (proc)

72−import Text.URI

76+import qualified Text.URI as URI

7377

7478import Obelisk.App (MonadObelisk)

7579import Obelisk.CliApp

@@ -111,37 +115,63 @@ data GitHubSource = GitHubSource

111115 { _gitHubSource_owner :: Name Owner

112116 , _gitHubSource_repo :: Name Repo

113117 , _gitHubSource_branch :: Maybe (Name Branch)

118+ , _gitHubSource_private :: Bool

114119 }

115120 deriving (Show, Eq, Ord)

116121

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+

117131data GitSource = GitSource

118− { _gitSource_url :: URI

132+ { _gitSource_url :: GitUri

119133 , _gitSource_branch :: Maybe (Name Branch)

120134 , _gitSource_fetchSubmodules :: Bool

135+ , _gitSource_private :: Bool

121136 }

122137 deriving (Show, Eq, Ord)

123138

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+

124153-- | Convert a GitHub source to a regular Git source. Assumes no submodules.

125154forgetGithub :: Bool -> GitHubSource -> GitSource

126155forgetGithub useSsh s = GitSource

127− { _gitSource_url = URI

128− { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"

129− , uriAuthority = Right $ Authority

130− { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing

156+ { _gitSource_url = GitUri $ URI.URI

157+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"

158+ , URI.uriAuthority = Right $ URI.Authority

159+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing

131160 <$ guard useSsh

132− , authHost = fromRight' $ mkHost "github.com"

133− , authPort = Nothing

161+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

162+ , URI.authPort = Nothing

134163 }

135− , uriPath = Just ( False

136− , fromRight' . mkPathPiece <$>

164+ , URI.uriPath = Just ( False

165+ , fromRight' . URI.mkPathPiece <$>

137166 untagName (_gitHubSource_owner s)

138167 :| [ untagName (_gitHubSource_repo s) <> ".git" ]

139168 )

140− , uriQuery = []

141− , uriFragment = Nothing

169+ , URI.uriQuery = []

170+ , URI.uriFragment = Nothing

142171 }

143172 , _gitSource_branch = _gitHubSource_branch s

144173 , _gitSource_fetchSubmodules = False

174+ , _gitSource_private = _gitHubSource_private s

145175 }

146176

147177getThunkGitBranch :: ThunkPtr -> Maybe Text

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

155185-- TODO: Use spinner here.

156186getNixSha256ForUriUnpacked

157187 :: MonadObelisk m

158− => URI

188+ => GitUri

159189 -> m NixSha256

160190getNixSha256ForUriUnpacked 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

162192 [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]

164194 pure hash

165195

166−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256

196+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256

167197nixPrefetchGit 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

169199 out <- readProcessAndLogStderr Debug $

170200 proc "nix-prefetch-git" $ filter (/="")

171− [ "--url", T.unpack $ render uri

201+ [ "--url", T.unpack $ gitUriToText uri

172202 , "--rev", T.unpack rev

173203 , if fetchSubmodules then "--fetch-submodules" else ""

174204 , "--quiet"

@@ -286,10 +316,12 @@ parseGitHubSource v = do

286316 owner <- v Aeson..: "owner"

287317 repo <- v Aeson..: "repo"

288318 branch <- v Aeson..:! "branch"

319+ private <- v Aeson..:? "private"

289320 pure $ GitHubSource

290321 { _gitHubSource_owner = owner

291322 , _gitHubSource_repo = repo

292323 , _gitHubSource_branch = branch

324+ , _gitHubSource_private = fromMaybe False private

293325 }

294326

295327parseGitSource :: Aeson.Object -> Aeson.Parser GitSource

@@ -297,10 +329,12 @@ parseGitSource v = do

297329 Just url <- parseGitUri <$> v Aeson..: "url"

298330 branch <- v Aeson..:! "branch"

299331 fetchSubmodules <- v Aeson..:! "fetchSubmodules"

332+ private <- v Aeson..:? "private"

300333 pure $ GitSource

301334 { _gitSource_url = url

302335 , _gitSource_branch = branch

303336 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules

337+ , _gitSource_private = fromMaybe False private

304338 }

305339

306340overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()

@@ -327,13 +361,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

327361 , ("branch" .=) <$> _gitHubSource_branch s

328362 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

329363 , Just $ "sha256" .= _thunkRev_nixSha256 rev

364+ , Just $ "private" .= _gitHubSource_private s

330365 ]

331366 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes

332− [ Just $ "url" .= render (_gitSource_url s)

367+ [ Just $ "url" .= gitUriToText (_gitSource_url s)

333368 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

334369 , ("branch" .=) <$> _gitSource_branch s

335370 , Just $ "sha256" .= _thunkRev_nixSha256 rev

336371 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

372+ , Just $ "private" .= _gitSource_private s

337373 ]

338374 where

339375 githubCfg = defConfig

@@ -354,6 +390,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

354390 [ "url"

355391 , "rev"

356392 , "sha256"

393+ , "private"

357394 , "fetchSubmodules"

358395 ] <> compare

359396 , confTrailingNewline = True

@@ -377,8 +414,8 @@ createThunkWithLatest target s = do

377414 , _thunkPtr_rev = rev

378415 }

379416

380−updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()

381−updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do

417+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()

418+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do

382419 checkThunkDirectory "ob thunk update directory cannot be '.'" target

383420 -- check to see if thunk should be updated to a specific branch or just update it's current branch

384421 case mBranch of

@@ -390,7 +427,7 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t

390427 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"

391428 let src = _thunkPtr_source ptr

392429 rev <- getLatestRev src

393− overwriteThunk overwrite $ ThunkPtr

430+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr

394431 { _thunkPtr_source = src

395432 , _thunkPtr_rev = rev

396433 }

@@ -398,24 +435,25 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t

398435 Left err -> failWith $ T.pack $ "thunk update: " <> show err

399436 Right c -> case c of

400437 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

402439 ThunkSource_GitHub tsgh -> do

403440 let tsg = forgetGithub False tsgh

404− setThunk 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."

441+ setThunk thunkConfig target tsg branch

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

406443

407−setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()

408−setThunk target gs branch = do

444+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()

445+setThunk thunkConfig target gs branch = do

409446 newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing

410447 overwriteThunk target newThunkPtr

411− updateThunkToLatest target Nothing

448+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target

412449

413450-- | All recognized github standalone loaders, ordered from newest to oldest.

414451-- This tool will only ever produce the newest one when it writes a thunk.

415452gitHubStandaloneLoaders :: NonEmpty Text

416453gitHubStandaloneLoaders =

417− gitHubStandaloneLoaderV2 :|

454+ gitHubStandaloneLoaderV4 :|

418455 [ gitHubStandaloneLoaderV3

456+ , gitHubStandaloneLoaderV2

419457 , gitHubStandaloneLoaderV1

420458 ]

421459

@@ -455,10 +493,23 @@ gitHubStandaloneLoaderV3 = T.unlines

455493 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

456494 ]

457495

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+

458508plainGitStandaloneLoaders :: NonEmpty Text

459509plainGitStandaloneLoaders =

460− plainGitStandaloneLoaderV1 :|

461− [ plainGitStandaloneLoaderV2

510+ plainGitStandaloneLoaderV3 :|

511+ [ plainGitStandaloneLoaderV1

512+ , plainGitStandaloneLoaderV2

462513 ]

463514

464515plainGitStandaloneLoaderV1 :: Text

@@ -479,6 +530,22 @@ plainGitStandaloneLoaderV2 = T.unlines

479530 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

480531 ]

481532

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+

482549thunkFileNames :: [FilePath]

483550thunkFileNames = ["default.nix", "github.json", "git.json"]

484551

@@ -520,7 +587,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do

520587 Just c -> return c

521588 Nothing -> do

522589 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

523− _ <- nixCmd $ NixCmd_Build$ def

590+ _ <- nixCmd $ NixCmd_Build $ def

524591 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

525592 Lens.& nixCmdConfig_target Lens..~ Target

526593 { _target_path = Just thunkDir

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

570637 callProcessAndLogOutput (Notice, Error) $

571638 proc "cp" ["-r", "-T", thunkDir, tmpThunk]

572639 return tmpThunk

573− Right _ -> failWith $ "Thunk is not packed"

640+ Right _ -> failWith "Thunk is not packed"

574641 updateThunkFromTmp p' = do

575− _ <- packThunk' True False p'

642+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'

576643 callProcessAndLogOutput (Notice, Error) $

577644 proc "cp" ["-r", "-T", p', p]

578645

@@ -606,7 +673,7 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with

606673 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo

607674 git $ [ "clone" ]

608675 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))

609− ++ [ T.unpack $ render $ _gitSource_url s ]

676+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]

610677 ++ do branch <- maybeToList $ _gitSource_branch s

611678 [ "--branch", T.unpack $ untagName branch ]

612679 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

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

622689 proc "mv" ["-T", tmpRepo, thunkDir]

623690

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

626693packThunk = packThunk' False

627694

628−packThunk' :: MonadObelisk m => Bool -> Bool -> FilePath -> m ThunkPtr

629−packThunk' noTrail force thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case

695+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr

696+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case

630697 Left err -> failWith $ T.pack $ "thunk pack: " <> show err

631698 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

632699 Right (ThunkData_Checkout _) -> do

633700 withSpinner' ("Packing thunk " <> T.pack thunkDir)

634701 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do

635− thunkPtr <- getThunkPtr (not force) thunkDir

702+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir

636703 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]

637704 liftIO $ createThunk thunkDir thunkPtr

638705 pure thunkPtr

639706

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+

640715getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr

641716getThunkPtr checkClean thunkDir = do

642− when checkClean $ ensureCleanGitRepo thunkDir True $

717+ when checkClean $ ensureCleanGitRepo thunkDir True

643718 "thunk pack: thunk checkout contains unsaved modifications"

644719

645720 -- Check whether there are any stashes

@@ -661,7 +736,7 @@ getThunkPtr checkClean thunkDir = do

661736 <$> T.lines

662737 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]

663738 case b of

664− (Just "HEAD") -> failWith $ T.unlines $

739+ (Just "HEAD") -> failWith $ T.unlines

665740 [ "thunk pack: You are in 'detached HEAD' state."

666741 , "If you want to pack at the current ref \

667742 \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

733808 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"

734809 , ""

735810 ] ++

736− (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat

811+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat

737812 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++

738813 [ ""

739814 , "Please push these upstream and try again. (Or just fetch, if they are somehow \

@@ -741,7 +816,7 @@ getThunkPtr checkClean thunkDir = do

741816 ]

742817

743818 -- 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."

745820

746821 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

747822

@@ -773,7 +848,7 @@ getLatestRev os = do

773848-- performance. If that doesn't work (e.g. authentication issue), we fall back

774849-- on just doing things the normal way for git repos in general, and save it as

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

777852uriThunkPtr uri mbranch mcommit = do

778853 commit <- case mcommit of

779854 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd

@@ -784,7 +859,7 @@ uriThunkPtr uri mbranch mcommit = do

784859 case rev of

785860 Right r -> pure (ThunkSource_GitHub s, r)

786861 Left e -> do

787− putLog Warning $ "\

862+ putLog Warning "\

788863\Failed to fetch archive from GitHub. This is probably a private repo. \

789864\Falling back on normal fetchgit. Original failure:"

790865 errorToWarning e

@@ -801,33 +876,33 @@ uriThunkPtr uri mbranch mcommit = do

801876-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with

802877-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method

803878-- should be employed, and so we respect that.

804−uriToThunkSource :: URI -> Maybe Text -> ThunkSource

805−uriToThunkSource u

806− | Right uriAuth <- uriAuthority u

807− , Just scheme <- unRText <$> uriScheme u

879+uriToThunkSource :: GitUri -> Maybe Text -> ThunkSource

880+uriToThunkSource (GitUri u)

881+ | Right uriAuth <- URI.uriAuthority u

882+ , Just scheme <- URI.unRText <$> URI.uriScheme u

808883 , case scheme of

809− "ssh" -> uriAuth == Authority

810− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing

811− , authHost = fromRight' $ mkHost "github.com"

812− , authPort = Nothing

884+ "ssh" -> uriAuth == URI.Authority

885+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing

886+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

887+ , URI.authPort = Nothing

813888 }

814889 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"

815− && unRText (authHost uriAuth) == "github.com"

816− , Just (_, owner :| [repoish]) <- uriPath u

890+ && URI.unRText (URI.authHost uriAuth) == "github.com"

891+ , Just (_, owner :| [repoish]) <- URI.uriPath u

817892 = \mbranch -> ThunkSource_GitHub $ GitHubSource

818− { _gitHubSource_owner = N $ unRText owner

893+ { _gitHubSource_owner = N $ URI.unRText owner

819894 , _gitHubSource_repo = N $ let

820− repoish' = unRText repoish

821− in case T.stripSuffix ".git" repoish' of

822− Just repo -> repo

823− Nothing -> repoish'

895+ repoish' = URI.unRText repoish

896+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'

824897 , _gitHubSource_branch = N <$> mbranch

898+ , _gitHubSource_private = False -- TODO: Can we try something to infer this?

825899 }

826900

827901 | otherwise = \mbranch -> ThunkSource_Git $ GitSource

828− { _gitSource_url = u

902+ { _gitSource_url = GitUri u

829903 , _gitSource_branch = N <$> mbranch

830904 , _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?

831906 }

832907

833908-- Funny signature indicates no effects depend on the optional branch name.

@@ -840,19 +915,19 @@ githubThunkRev

840915githubThunkRev s commit = do

841916 owner <- forcePP $ _gitHubSource_owner s

842917 repo <- forcePP $ _gitHubSource_repo s

843− revTarball <- mkPathPiece $ commit <> ".tar.gz"

844− let archiveUri = URI

845− { uriScheme = Just $ fromRight' $ mkScheme "https"

846− , uriAuthority = Right $ Authority

847− { authUserInfo = Nothing

848− , authHost = fromRight' $ mkHost "github.com"

849− , authPort = Nothing

918+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"

919+ let archiveUri = GitUri $ URI.URI

920+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"

921+ , URI.uriAuthority = Right $ URI.Authority

922+ { URI.authUserInfo = Nothing

923+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

924+ , URI.authPort = Nothing

850925 }

851− , uriPath = Just ( False

852− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]

926+ , URI.uriPath = Just ( False

927+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]

853928 )

854− , uriQuery = []

855− , uriFragment = Nothing

929+ , URI.uriQuery = []

930+ , URI.uriFragment = Nothing

856931 }

857932 hash <- getNixSha256ForUriUnpacked archiveUri

858933 putLog Debug $ "Nix sha256 is " <> hash

@@ -861,8 +936,8 @@ githubThunkRev s commit = do

861936 , _thunkRev_nixSha256 = hash

862937 }

863938 where

864− forcePP :: Name entity -> m (RText 'PathPiece)

865− forcePP = mkPathPiece . untagName

939+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)

940+ forcePP = URI.mkPathPiece . untagName

866941

867942gitThunkRev

868943 :: MonadObelisk m

@@ -871,11 +946,11 @@ gitThunkRev

871946 -> m ThunkRev

872947gitThunkRev s commit = do

873948 let u = _gitSource_url s

874− protocols = ["https", "ssh", "git"]

875− Just scheme <- pure $ unRText <$> uriScheme u

949+ protocols = ["file", "https", "ssh", "git"]

950+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u

876951 unless (T.toLower scheme `elem` protocols) $

877952 failWith $ "obelisk currently only supports "

878− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"

953+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"

879954 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s

880955 putLog Informational $ "Nix sha256 is " <> hash

881956 pure $ ThunkRev

@@ -889,10 +964,10 @@ gitThunkRev s commit = do

889964-- If the branch name is passed in, it is returned exactly as-is. If it is not

890965-- passed it, the default branch of the repo is used instead.

891966gitGetCommitBranch

892− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)

967+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)

893968gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do

894969 (_, bothMaps) <- gitLsRemote

895− (T.unpack $ render uri)

970+ (T.unpack $ gitUriToText uri)

896971 (GitRef_Branch <$> mbranch)

897972 Nothing

898973 branch <- case mbranch of

@@ -908,18 +983,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "

908983 pure (branch, commit)

909984 where

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

912990

913−parseGitUri :: Text -> Maybe URI

914−parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x

991+parseFileURI :: Text -> Maybe URI.URI

992+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing

915993

916−parseAbsoluteURI :: Text -> Maybe URI

994+parseAbsoluteURI :: Text -> Maybe URI.URI

917995parseAbsoluteURI uri = do

918− parsedUri <- mkURI uri

919− guard $ isPathAbsolute parsedUri

920− pure $ parsedUri

996+ parsedUri <- URI.mkURI uri

997+ guard $ URI.isPathAbsolute parsedUri

998+ pure parsedUri

921999

922−parseSshShorthand :: Text -> Maybe URI

1000+parseSshShorthand :: Text -> Maybe URI.URI

9231001parseSshShorthand uri = do

9241002 -- This is what git does to check that the remote

9251003 -- is not a local file path when parsing shorthand.

@@ -932,4 +1010,4 @@ parseSshShorthand uri = do

9321010 -- This check is used to disambiguate a filepath containing a colon from shorthand

9331011 guard $ isNothing (T.findIndex (=='/') authAndHostname)

9341012 && 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)

2323import System.Directory (canonicalizePath)

2424import System.Environment (getExecutablePath)

2525import System.Exit (ExitCode)

26−import qualified System.Process as P

2726import Text.Megaparsec as MP

2827import Text.Megaparsec.Char as MP

2928

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

6160 git ["add", "."]

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

6362

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

65−gitProcNoRepo = P.proc "git"

63+gitProcNoRepo :: [String] -> ProcessSpec

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

6665

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

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

6867gitProc repo = gitProcNoRepo . runGitInDir

6968 where

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

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

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

7372

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

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

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+

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

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

7685copyDir 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

7887

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

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

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

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

8897

8998-- | 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 ()

91100runProc = callProcessAndLogOutput (Notice, Error)

92101

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

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

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

95104runProcSilently = callProcessAndLogOutput (Debug, Debug)

96105

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

99108readProc = readProcessAndLogOutput (Debug, Error)

100109

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

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

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

130139 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

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

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

133− Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo $

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

142+ Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo

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

135144 let t = T.pack out

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

137146 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

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

140149 pure (exitCode, maps)

141150

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

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

1818import System.Exit (ExitCode(..))

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

2020import qualified System.Info

21−import System.Process (proc)

2221

2322import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

2423import Obelisk.CliApp

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

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

2727 build-depends: directory

2828

2929 build-depends:

30− base,

30+ base,

3131 base64-bytestring,

3232 bytestring,

3333 containers,

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

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

881881 gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y

882882

883883instance (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]

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

886886

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

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

130130 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

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

133133 Just "https" -> do

134134 -- Generate a private key and self-signed certificate for TLS

135135 privateKey <- RSA.generateRSAKey' 2048 3

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

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

33{-# LANGUAGE OverloadedStrings #-}

44{-# LANGUAGE PatternGuards #-}

55{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE ViewPatterns #-}

67module Obelisk.SelfTest where

89import Control.Exception (bracket, throw)

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

2425import System.Directory (withCurrentDirectory, getDirectoryContents)

2526import System.Environment

2627import System.Exit (ExitCode (..))

27−import System.Info

28+import qualified System.Info

2829import System.IO (Handle, hClose)

2930import System.IO.Temp

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

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

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

7677 let verbosity = bool silently verbosely isVerbose

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

7997 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

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

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

82− -- Setup the ob init cache

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

84− run_ "ob" ["init"]

85− run_ "git" ["init"]

99+

100+ withObeliskImpl $ \obeliskImpl initCache ->

86101 hspec $ parallel $ do

87102 let shelly_ = void . shellyOb verbosity

88103

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

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

91106

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

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

93108

94109 inTmpObInit f = inTmp $ \dir -> do

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

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

96111 f dir

97112

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

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

115130 describe "ob init" $ parallel $ do

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

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

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

119− 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 }

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

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

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

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

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

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

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

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

140155

141156 describe "obelisk project" $ parallel $ do

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

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

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

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

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

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

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

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

146161

147162 describe "blank initialized project" $ parallel $ do

148163

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

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

151166

152− if os == "darwin"

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

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

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

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

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

162177

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

164179 let

165− shell = "shells." <> compiler

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

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

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

180+ shellName = "shells." <> compiler

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

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

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

169184

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

186+ _ <- pack

171187 u <- update

172188 uu <- update

173189 assertRevEQ u uu

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

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

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

177193

194+ _ <- pack

178195 e <- commitAll

179196 eu <- unpack

180197 eup <- pack

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

212229 testThunkPack $ fromText repo

213230

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

215− void unpack

216232 testThunkPack (dir </> thunk)

217233

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

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

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

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

239255 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

241257 firstUri <- handleObRunStdout httpManager stdout

242258 let newUri = uri p1

243259 when (firstUri == newUri) $ errorExit $

lib/tabulation/src/Data/Tabulation.hs+1−1

@@ -8,7 +8,7 @@ import Control.Lens

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

99class HasFields a where

1010 type Field a :: * -> *

11−

11+

1212 fieldLens :: Field a x -> Lens' a x

1313 tabulateFieldsA :: Applicative f => (forall x. Field a x -> f x) -> f a

1414

skeleton/.gitignore+1

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

11dist-newstyle

22result

3+result-*

34result-android

45result-ios

56result-exe

skeleton/common/common.cabal−3

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

99 , obelisk-route

1010 , mtl

1111 , text

12− default-extensions:

13− TypeFamilies

14− PolyKinds

1512 exposed-modules:

1613 Common.Api

1714 Common.Route

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

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

88{-# LANGUAGE OverloadedStrings #-}

99{-# LANGUAGE RankNTypes #-}

1010{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeFamilies #-}

1112module Common.Route where

1213

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

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

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

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE TypeApplications #-}

45module Frontend where

67import qualified Data.Text as T

78import qualified Data.Text.Encoding as T

810import Obelisk.Frontend

911import Obelisk.Configs

1012import Obelisk.Route

13+import Obelisk.Generated.Static

14+

1115import Reflex.Dom.Core

1216

1317import Common.Api

1418import Common.Route

15−import Obelisk.Generated.Static

19+

1620

1721frontend :: Frontend (R FrontendRoute)

1822frontend = Frontend

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

23+ { _frontend_head = do

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

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

2026 , _frontend_body = do

21− text "Welcome to Obelisk!"

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

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

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

2430 el "div" $ do

skeleton/static/main.cssnew file+3

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

1+p {

2+ color: red;

3+}