9a0e494 · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge branch 'develop' into an-binary-caches

commit9a0e49487a8b08c4dd0bc51f767af66d4adeb707 authorElliot Cameron <3noch@users.noreply.github.com> dateTue 14 Jan 2020, 14:21 (7 years ago) parent7443dd7 678d2d6

40 files changed+911−930

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

@@ -2,6 +2,17 @@

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+## v0.4.0.0 - 2020-01-10

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

15+

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

617

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

README.md+1−1

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

153153

154154### Running over https

155155

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

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

157157

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

159159

acme.nixdeleted−397

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

1−### COPIED FROM

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

3−###

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

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

6−

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

8−

9−with lib;

10−

11−let

12−

13− cfg = config.security.acme;

14−

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

16− options = {

17− webroot = mkOption {

18− type = types.str;

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

20− description = ''

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

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

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

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

25− be available (notice unencrypted HTTP).

26− '';

27− };

28−

29− domain = mkOption {

30− type = types.str;

31− default = name;

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

33− };

34−

35− email = mkOption {

36− type = types.nullOr types.str;

37− default = null;

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

39− };

40−

41− user = mkOption {

42− type = types.str;

43− default = "root";

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

45− };

46−

47− group = mkOption {

48− type = types.str;

49− default = "root";

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

51− };

52−

53− allowKeysForGroup = mkOption {

54− type = types.bool;

55− default = false;

56− description = ''

57− Give read permissions to the specified group

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

59− '';

60− };

61−

62− postRun = mkOption {

63− type = types.lines;

64− default = "";

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

66− description = ''

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

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

69− be reloaded.

70−

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

72− '';

73− };

74−

75− plugins = mkOption {

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

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

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

79− ]);

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

81− description = ''

82− Plugins to enable. With default settings simp_le will

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

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

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

86− '';

87− };

88−

89− activationDelay = mkOption {

90− type = types.nullOr types.str;

91− default = null;

92− description = ''

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

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

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

96− '';

97− };

98−

99− preDelay = mkOption {

100− type = types.lines;

101− default = "";

102− description = ''

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

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

105−

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

107− '';

108− };

109−

110− extraDomains = mkOption {

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

112− default = {};

113− example = literalExample ''

114− {

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

116− "mydomain.org" = null;

117− }

118− '';

119− description = ''

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

121− own server roots if needed.

122− '';

123− };

124− };

125− };

126−

127−in

128−

129−{

130−

131− ###### interface

132−

133− options = {

134− security.acme = {

135− directory = mkOption {

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

137− type = types.str;

138− description = ''

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

140− '';

141− };

142−

143− validMin = mkOption {

144− type = types.int;

145− default = 30 * 24 * 3600;

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

147− };

148−

149− renewInterval = mkOption {

150− type = types.str;

151− default = "weekly";

152− description = ''

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

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

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

156− '';

157− };

158−

159− preliminarySelfsigned = mkOption {

160− type = types.bool;

161− default = true;

162− description = ''

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

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

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

166−

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

168− can later reload the correct ACME certificates.

169− '';

170− };

171−

172− production = mkOption {

173− type = types.bool;

174− default = true;

175− description = ''

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

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

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

179−

180− See

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

182− for more detail.

183− '';

184− };

185−

186− certs = mkOption {

187− default = { };

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

189− description = ''

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

191− '';

192− example = literalExample ''

193− {

194− "example.com" = {

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

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

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

198− };

199− "bar.example.com" = {

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

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

202− };

203− }

204− '';

205− };

206− };

207− };

208−

209− ###### implementation

210− config = mkMerge [

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

212−

213− systemd.services = let

214− services = concatLists servicesLists;

215− servicesLists = mapAttrsToList certToServices cfg.certs;

216− certToServices = cert: data:

217− let

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

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

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

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

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

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

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

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

226− acmeService = {

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

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

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

230− serviceConfig = {

231− Type = "oneshot";

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

233− PermissionsStartOnly = true;

234− User = data.user;

235− Group = data.group;

236− PrivateTmp = true;

237− };

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

239− preStart = ''

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

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

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

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

244− mkdir '${cpath}'

245− fi

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

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

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

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

250− '';

251− script = ''

252− cd '${cpath}'

253− set +e

254− simp_le ${escapeShellArgs cmdline}

255− EXITCODE=$?

256− set -e

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

258− exit "$EXITCODE"

259− '';

260− postStop = ''

261− cd '${cpath}'

262−

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

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

265−

266− ${data.preDelay}

267−

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

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

270− else

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

272− fi

273− '' else data.postRun}

274−

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

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

277− true

278− fi

279− '';

280−

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

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

283− };

284− delayService = {

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

286− path = with pkgs; [ rsync ];

287− serviceConfig = {

288− Type = "oneshot";

289− };

290− script = ''

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

292− '';

293− postStop = data.postRun;

294− };

295− selfsignedService = {

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

297− path = [ pkgs.openssl ];

298− preStart = ''

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

300− then

301− mkdir -p '${cpath}'

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

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

304− fi

305− '';

306− script =

307− ''

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

309−

310− # Create CA

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

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

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

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

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

316−

317− # Create key

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

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

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

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

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

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

324− -out $workdir/server.crt

325−

326− # Copy key to destination

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

328−

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

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

331−

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

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

334−

335− # Give key acme permissions

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

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

338− '';

339− serviceConfig = {

340− Type = "oneshot";

341− PermissionsStartOnly = true;

342− PrivateTmp = true;

343− User = data.user;

344− Group = data.group;

345− };

346− unitConfig = {

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

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

349− };

350− before = [

351− "acme-selfsigned-certificates.target"

352− ];

353− wantedBy = [

354− "acme-selfsigned-certificates.target"

355− ];

356− };

357− in (

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

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

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

361− );

362− servicesAttr = listToAttrs services;

363− injectServiceDep = {

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

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

366− };

367− in

368− servicesAttr //

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

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

371−

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

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

374− ({

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

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

377− timerConfig = {

378− OnCalendar = cfg.renewInterval;

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

380− Persistent = "yes";

381− AccuracySec = "5m";

382− RandomizedDelaySec = "1h";

383− };

384− })

385− );

386−

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

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

389− })

390−

391− ];

392−

393− meta = {

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

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

396− };

397−}

all-builds.nixnew file+117

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

1+{ self-args ? {

2+ config.android_sdk.accept_license = true;

3+ iosSdkVersion = "10.2";

4+ }

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

6+, supportedSystems ? [

7+ "x86_64-linux"

8+ "x86_64-darwin"

9+ ]

10+}:

11+

12+let

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

14+ cacheBuildSystems = supportedSystems;

15+

16+ obeliskPackagesCommon = [

17+ "obelisk-frontend"

18+ "obelisk-route"

19+ "obelisk-executable-config-lookup"

20+ ];

21+

22+ obeliskPackagesBackend = obeliskPackagesCommon ++ [

23+ "obelisk-asset-manifest"

24+ "obelisk-asset-serve-snap"

25+ "obelisk-backend"

26+ "obelisk-cliapp"

27+ "obelisk-command"

28+ "obelisk-executable-config-inject"

29+ "obelisk-frontend"

30+ "obelisk-run"

31+ "obelisk-route"

32+ "obelisk-selftest"

33+ "obelisk-snap-extras"

34+ ];

35+

36+ pnameToAttrs = pkgsSet: pnames:

37+ lib.listToAttrs (map

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

39+ pnames);

40+

41+ concatDepends = let

42+ extractDeps = x: (x.override {

43+ mkDerivation = drv: {

44+ out = builtins.concatLists [

45+ (drv.buildDepends or [])

46+ (drv.libraryHaskellDepends or [])

47+ (drv.executableHaskellDepends or [])

48+ ];

49+ };

50+ }).out;

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

52+

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

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

55+ perProfiling = profiling: let

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

57+ ghc = pnameToAttrs

58+ obelisk.haskellPackageSets.ghc

59+ obeliskPackagesBackend;

60+ ghcjs = pnameToAttrs

61+ obelisk.haskellPackageSets.ghcjs

62+ obeliskPackagesCommon;

63+ cachePackages = builtins.concatLists [

64+ (builtins.attrValues ghc)

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

66+ (concatDepends ghc)

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

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

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

70+ (lib.optionals (!profiling) [

71+ command

72+ serverSkeletonExe

73+ serverSkeletonShell

74+ ])

75+ ];

76+ command = obelisk.command;

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

78+ serverSkeletonExe = skeleton.exe;

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

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

81+ touch "$out"

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

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

84+ '';

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

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

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

88+ in {

89+ inherit

90+ ghc

91+ ;

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

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

94+ inherit

95+ command

96+ ghcjs

97+ serverSkeletonExe

98+ serverSkeletonShell

99+ ;

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

101+ inherit androidSkeleton;

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

103+ inherit iosSkeleton;

104+ };

105+ profiled = perProfiling true;

106+ unprofiled = perProfiling false;

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

108+ in {

109+ inherit profiled unprofiled;

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

111+ });

112+

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

114+ "obelisk-everywhere"

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

116+

117+in perPlatform // { inherit metaCache; }

all-tests.nixnew file+107

@@ -0,0 +1,107 @@

1+{

2+ supportedSystems ? [ builtins.currentSystem ]

3+}:

4+let

5+ nginxRoot = "/run/nginx";

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

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

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

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

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

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

12+ snakeOilPrivateKey = sshKeys.snakeOilPrivateKey.text;

13+ snakeOilPublicKey = sshKeys.snakeOilPublicKey;

14+in

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

16+ name = "obelisk";

17+ nodes = {

18+ githost = {

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

20+ services.openssh = {

21+ enable = true;

22+ };

23+ environment.systemPackages = [

24+ pkgs.git

25+ ];

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

27+ snakeOilPublicKey

28+ ];

29+ };

30+

31+ client = {

32+ imports = [

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

34+ ];

35+ nix.useSandbox = false;

36+ nix.binaryCaches = [];

37+ environment.systemPackages = [

38+ obelisk.command

39+ obelisk.shell

40+ obelisk-everywhere

41+ pkgs.git

42+ ];

43+ };

44+ };

45+

46+ testScript =

47+ let

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

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

50+ Host *

51+ StrictHostKeyChecking no

52+ UserKnownHostsFile=/dev/null

53+ ConnectionAttempts=1

54+ ConnectTimeout=1

55+ IdentityFile=~/.ssh/id_rsa

56+ User=root

57+ '';

58+ in ''

59+ start_all()

60+ githost.wait_for_open_port("22")

61+

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

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

64+

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

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

67+ client.succeed(

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

69+ )

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

71+ client.wait_until_succeeds(

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

73+ )

74+ client.succeed(

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

76+ )

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

78+

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

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

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

82+

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

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

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

86+ client.succeed("cd ~/code/myapp && touch README")

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

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

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

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

91+ client.succeed(

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

93+ )

94+

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

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

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

98+

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

100+ client.succeed("ob thunk pack ~/code/myapp")

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

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

103+

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

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

106+ '';

107+ }) {}

default.nix+25−29

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

22, profiling ? false

33, iosSdkVersion ? "10.2"

44, config ? {}

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

56}:

67let

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

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

1617 openssh

1718 ];

1819

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

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

2021 inherit iosSdkVersion config;

2122 system = sys;

2223 enableLibraryProfiling = profiling;

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

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

3536 haskellLib = pkgs.haskell.lib;

3637 in {

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

38− jailbreak = true;

39− doCheck = false;

40− });

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

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

4240

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

@@ -50,6 +48,8 @@ let

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

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

5250 in {

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

52+

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

5454

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

@@ -67,7 +67,12 @@ let

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

6868 );

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

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

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

71+ librarySystemDepends = [

72+ pkgs.cabal-install

73+ pkgs.coreutils

74+ ];

75+ };

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

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

7378 })

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

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

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

118123 obelisk = ghcObelisk;

119− obeliskEnvs = ghcObeliskEnvs;

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

120125 command = ghcObelisk.obelisk-command;

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

122127

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

125130 set -euo pipefail

126131

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

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

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

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

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

130136 '';

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

132137 skeleton = pkgs.runCommand "skeleton" {

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

134139 } ''

@@ -150,6 +155,7 @@ in rec {

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

151156 mkdir $out

152157 cd $out

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

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

154160 ${if optimizationLevel == null then ''

155161 ln -s all.unminified.js all.js

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

232238 pkgs.runCommand "serverExe" {} ''

233239 mkdir $out

234240 set -eux

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

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

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

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

238244 echo ${version} > $out/version

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

247253 imports = [

248254 (serverModules.mkBaseEc2 args)

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

261256 ];

262257 };

263258 };

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

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

342337 };

343338 in mkProject (projectDefinition args));

344− serverOn = sys: version: serverExe

345− (projectOut sys).ghc.backend

346− (projectOut system).ghcjs.frontend

347− (projectOut sys).passthru.staticFiles

348− (projectOut sys).passthru.__closureCompilerOptimizationLevel

339+ mainProjectOut = projectOut system;

340+ serverOn = projectInst: version: serverExe

341+ projectInst.ghc.backend

342+ mainProjectOut.ghcjs.frontend

343+ projectInst.passthru.staticFiles

344+ projectInst.passthru.__closureCompilerOptimizationLevel

349345 version;

350− linuxExe = serverOn "x86_64-linux";

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

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

352− in projectOut system // {

348+ in mainProjectOut // {

353349 linuxExeConfigurable = linuxExe;

354350 linuxExe = linuxExe dummyVersion;

355− exe = serverOn system dummyVersion;

351+ exe = serverOn mainProjectOut dummyVersion;

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

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

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

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+2−2

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

22 "owner": "reflex-frp",

33 "repo": "reflex-platform",

44 "branch": "develop",

5− "rev": "aa8a9d1ac3d41ad51fbe04e575d4350da65cf3db",

6− "sha256": "0hffy5rcfy6ay06ww3cxykqzp024jfcdg6w1yrmnf0h80sjfgdcm"

5+ "rev": "90351bdb2c99d416ea95fd5b8b474e8f9fab2942",

6+ "sha256": "0bbzz4ckdx0ilhhpd3drfbsc0zdb2rnhw2m3nls9villbs3lz3lh"

77}

jobsets.nixdeleted−71

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

1−{ prs }:

2−

3−let

4− self = import ./. {};

5− pkgs = self.nixpkgs;

6− mkFetchGithub = value: {

7− inherit value;

8− type = "git";

9− emailresponsible = false;

10− };

11−in

12−with pkgs.lib;

13−let

14− defaults = jobs: {

15− inherit (jobs) description;

16− enabled = 1;

17− hidden = false;

18− keepnr = 10;

19− schedulingshares = 100;

20− checkinterval = 120;

21− enableemail = false;

22− emailoverride = "";

23− nixexprinput = "obelisk";

24− nixexprpath = "release.nix";

25− inputs = jobs.inputs // {

26− nixpkgs = {

27− type = "git";

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

29− emailresponsible = false;

30− };

31− };

32− self-args = {

33− type = "nix";

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

35− emailresponsible = false;

36− };

37− };

38− branchJobset = branch: defaults {

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

40− inputs = {

41− obelisk = {

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

43− type = "git";

44− emailresponsible = false;

45− };

46− };

47− };

48− makePr = num: info: {

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

50− value = defaults {

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

52− inputs = {

53− obelisk = {

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

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

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

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

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

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

60− type = "git";

61− emailresponsible = false;

62− };

63− };

64− };

65− };

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

67− jobsetsAttrs = processedPrs //

68− genAttrs ["master"] branchJobset;

69−in {

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

71−}

lib/asset/README.md+10−10

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

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/obelisk-command.cabal+1−1

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

11name: obelisk-command

2−version: 0.3

2+version: 0.4

33cabal-version: >= 1.8

44build-type: Simple

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+12−12

@@ -25,22 +25,23 @@ 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

4242import Obelisk.Command.Utils

4343

44+

4445deployInit

4546 :: MonadObelisk m

4647 => ThunkPtr

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

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

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

5960 callProcessAndLogOutput (Notice, Error) $

60− proc "cp" [sshKeyPath, localKey]

61+ proc cp [sshKeyPath, localKey]

6162 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode

6263 return localKey

6364 withSpinner "Validating configuration" $ do

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

8283 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames

8384 writeDeployConfig deployDir "enable_https" $ show enableHttps

8485 writeDeployConfig deployDir "admin_email" adminEmail

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

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

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

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

8889 setupObeliskImpl deployDir

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

107108 Right (ThunkData_Packed ptr) -> return ptr

108109 Right (ThunkData_Checkout _) -> do

109110 checkGitCleanStatus srcPath True >>= \case

110− True -> packThunk False srcPath

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

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

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

113114 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr

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

157158 ]

158159 isClean <- checkGitCleanStatus deployPath True

159160 when (not isClean) $ do

160− withSpinner "Commiting changes to Git" $ do

161+ withSpinner "Committing changes to Git" $ do

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

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

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

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

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

166167 where

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

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

170170 callProcessAndLogOutput (Notice, Notice) p

171171

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

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

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

174174

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

176176keytoolToAndroidConfig conf =

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

219219 , _keytoolConfig_storepass = keyStorePassword

220220 , _keytoolConfig_keypass = keyStorePassword

221221 }

222− createKeystore root $ keyToolConf

222+ createKeystore root keyToolConf

223223 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

224224 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

225225 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

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

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

276276createKeystore root config = do

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

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

279279 where

280280 keytoolCmd = processToShellString "keytool"

281281 [ "-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+72−66

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

44{-# LANGUAGE OverloadedStrings #-}

55{-# LANGUAGE ScopedTypeVariables #-}

66{-# LANGUAGE TemplateHaskell #-}

7+{-# LANGUAGE TupleSections #-}

78module Obelisk.Command.Run where

9−import Control.Exception (bracket)

10+import Control.Applicative (liftA2)

11+import Control.Exception (Exception, bracket)

1012import Control.Monad

13+import Control.Monad.Except (runExceptT, throwError)

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

1215import Control.Monad.Reader (MonadIO)

1316import Data.Either

17+import Data.Foldable (for_)

1418import qualified Data.List as L

1519import qualified Data.List.NonEmpty as NE

1620import Data.Maybe

@@ -24,23 +28,18 @@ import Distribution.Types.CondTree

2428import Distribution.Types.GenericPackageDescription

2529import Distribution.Types.Library

2630import Distribution.Utils.Generic

27−import Hpack.Config

28−import Hpack.Render

29−import Hpack.Yaml

31+import qualified Hpack.Config as Hpack

32+import qualified Hpack.Render as Hpack

33+import qualified Hpack.Yaml as Hpack

3034import Language.Haskell.Extension

3135import Network.Socket hiding (Debug)

3236import System.Directory

3337import System.FilePath

34−import System.Process (proc)

3538import System.IO.Temp (withSystemTempDirectory)

3639import System.Which (staticWhich)

37−import Data.ByteString (ByteString)

3840

3941import Obelisk.App (MonadObelisk, ObeliskT)

40−import Obelisk.CliApp

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

42− , callCommand, failWith, getCliConfig, putLog

43− , readProcessAndLogStderr, runCli)

42+import Obelisk.CliApp (Severity (..) , callCommand, failWith, putLog, proc, readProcessAndLogStderr)

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

4544

4645data CabalPackageInfo = CabalPackageInfo

@@ -106,6 +105,27 @@ runWatch = do

106105 pkgs <- getLocalPkgs

107106 withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing

108107

108+data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound

109+ deriving (Eq, Ord, Show)

110+instance Exception GuessPackageFileError

111+

112+-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.

113+guessCabalPackageFile

114+ :: MonadIO m

115+ => FilePath -- ^ Directory to search for cabal package

116+ -> m (Either GuessPackageFileError (Either FilePath FilePath))

117+ -- ^ 'Right' 'Left' for hpack package, 'Right' 'Right' for cabal package; 'FilePath' is relative to given directory.

118+guessCabalPackageFile dir = do

119+ candidates <- liftIO $

120+ filterM (doesFileExist . (dir </>))

121+ =<< filter (liftA2 (||) (== Hpack.packageConfig) (".cabal" `L.isSuffixOf`))

122+ <$> listDirectory dir

123+ pure $ case L.partition (== Hpack.packageConfig) candidates of

124+ ([hpack], _) -> Right $ Left hpack

125+ ([], [cabal]) -> Right $ Right cabal

126+ ([], []) -> Left GuessPackageFileError_NotFound

127+ (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ hpacks <> cabals

128+

109129-- | Relative paths to local packages of an obelisk project

110130-- TODO a way to query this

111131getLocalPkgs :: Applicative f => f [FilePath]

@@ -115,67 +135,53 @@ parseCabalPackage

115135 :: (MonadObelisk m)

116136 => FilePath -- ^ package directory

117137 -> m (Maybe CabalPackageInfo)

118−parseCabalPackage dir = do

119− let cabalFp = dir </> (takeBaseName dir <> ".cabal")

120− hpackFp = dir </> "package.yaml"

121− hasCabal <- liftIO $ doesFileExist cabalFp

122− hasHpack <- liftIO $ doesFileExist hpackFp

123−

124− mCabalContents <- if hasCabal

125− then Just <$> liftIO (readUTF8File cabalFp)

126− else if hasHpack

127− then do

128− let decodeOptions = DecodeOptions (ProgramName "ob") hpackFp Nothing decodeYaml

129− liftIO (readPackageConfig decodeOptions) >>= \case

130− Left err -> do

131− putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err

132− return Nothing

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

134− return $ Just $ renderPackage [] hpackPackage

135− else return Nothing

136−

137− fmap join $ forM mCabalContents $ \cabalContents -> do

138− let (warnings, result) = runParseResult $ parseGenericPackageDescription $

139− toUTF8BS $ cabalContents

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

141− case result of

142− Right gpkg -> do

143− return $ do

144− (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg

145− pure $ CabalPackageInfo

146− { _cabalPackageInfo_packageRoot = takeDirectory cabalFp

147− , _cabalPackageInfo_sourceDirs =

148− fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

149− , _cabalPackageInfo_defaultExtensions =

150− defaultExtensions $ libBuildInfo lib

151− , _cabalPackageInfo_defaultLanguage =

152− defaultLanguage $ libBuildInfo lib

153− , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib

154− }

155− Left (_, errors) -> do

156− putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"

157− mapM_ (putLog Error) $ fmap (T.pack . show) errors

158− return Nothing

138+parseCabalPackage dir = either ((Nothing <$) . putLog Error) (pure . Just) <=< runExceptT $ do

139+ (cabalContents, packageFile) <- guessCabalPackageFile dir >>= \case

140+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack dir

141+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack dir

142+ Right (Right cabalFileName) -> let file = dir </> cabalFileName in (, file) <$> liftIO (readUTF8File file)

143+ Right (Left hpackFileName) -> do

144+ let

145+ file = dir </> hpackFileName

146+ decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml

147+ liftIO (Hpack.readPackageConfig decodeOptions) >>= \case

148+ Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err

149+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file)

159150

160−withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a

161−withUTF8FileContentsM fp f = do

162− c <- getCliConfig

163− liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS

151+ let (warnings, result) = runParseResult $ parseGenericPackageDescription $

152+ toUTF8BS cabalContents

153+ for_ warnings $ putLog Warning . T.pack . show

154+ case condLibrary <$> result of

155+ Right (Just condLib) -> do

156+ let (_, lib) = simplifyCondTree (const $ pure True) condLib

157+ pure $ CabalPackageInfo

158+ { _cabalPackageInfo_packageRoot = dir

159+ , _cabalPackageInfo_sourceDirs =

160+ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

161+ , _cabalPackageInfo_defaultExtensions =

162+ defaultExtensions $ libBuildInfo lib

163+ , _cabalPackageInfo_defaultLanguage =

164+ defaultLanguage $ libBuildInfo lib

165+ , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib

166+ }

167+ Right Nothing -> throwError "Haskell package has no library component"

168+ Left (_, errors) ->

169+ throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)

164170

165171-- | Create ghci configuration to load the given packages

166172withGhciScript

167173 :: MonadObelisk m

168174 => [FilePath] -- ^ List of packages to load into ghci

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

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

170176 -> m ()

171−withGhciScript pkgs f = do

172− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \pkg -> do

173− flip fmap (parseCabalPackage pkg) $ \case

174− Nothing -> Left pkg

177+withGhciScript dirs f = do

178+ (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM dirs $ \dir -> do

179+ flip fmap (parseCabalPackage dir) $ \case

180+ Nothing -> Left dir

175181 Just packageInfo -> Right packageInfo

176182

177183 when (null packageInfos) $

178− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs

184+ failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " dirs

179185 unless (null pkgDirErrs) $

180186 putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

181187

@@ -185,16 +191,16 @@ withGhciScript pkgs f = do

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

186192 extensionsLine = if extensions == mempty

187193 then ""

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

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

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

190196 packageInfos >>= _cabalPackageInfo_compilerOptions

191− dotGhci = unlines $

197+ dotGhci = unlines

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

193199 , case ghcOptions of

194200 [] -> ""

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

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

196202 , extensionsLine

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

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

198204 , ":load Backend Frontend"

199205 , "import Obelisk.Run"

200206 , "import qualified Frontend"

@@ -254,4 +260,4 @@ getFreePort = liftIO $ withSocketsDo $ do

254260 open addr = do

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

256262 bind sock (addrAddress addr)

257− return sock

263+ return sock

lib/command/src/Obelisk/Command/Thunk.hs+180−102

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

@@ -568,13 +635,13 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

568635 Right (ThunkData_Packed _) -> do

569636 let tmpThunk = tmpDir </> "thunk"

570637 callProcessAndLogOutput (Notice, Error) $

571− proc "cp" ["-r", "-T", thunkDir, tmpThunk]

638+ 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) $

577− proc "cp" ["-r", "-T", p', p]

644+ proc cp ["-r", "-T", p', p]

578645

579646finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)

580647finalMsg noTrail s = if noTrail then Nothing else Just s

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

@@ -615,31 +682,39 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with

615682

616683 liftIO $ createDirectory obGitDir

617684 callProcessAndLogOutput (Notice, Error) $

618− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]

685+ proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]

619686 callProcessAndLogOutput (Notice, Error) $

620687 proc "rm" ["-r", thunkDir]

621688 callProcessAndLogOutput (Notice, Error) $

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

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

44{-# LANGUAGE ScopedTypeVariables #-}

55{-# LANGUAGE OverloadedStrings #-}

66{-# LANGUAGE PatternGuards #-}

7+{-# LANGUAGE TemplateHaskell #-}

78module Obelisk.Command.Utils where

910import Control.Applicative hiding (many)

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

2324import System.Directory (canonicalizePath)

2425import System.Environment (getExecutablePath)

2526import System.Exit (ExitCode)

26−import qualified System.Process as P

27+import System.Which (staticWhich)

2728import Text.Megaparsec as MP

2829import Text.Megaparsec.Char as MP

2930

@@ -33,6 +34,9 @@ import Obelisk.CliApp

3334getObeliskExe :: IO FilePath

3435getObeliskExe = getExecutablePath >>= canonicalizePath

3536

37+cp :: FilePath

38+cp = $(staticWhich "cp")

39+

3640-- Check whether the working directory is clean

3741checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool

3842checkGitCleanStatus repo withIgnored = do

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

6165 git ["add", "."]

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

6367

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

65−gitProcNoRepo = P.proc "git"

68+gitProcNoRepo :: [String] -> ProcessSpec

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

6670

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

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

6872gitProc repo = gitProcNoRepo . runGitInDir

6973 where

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

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

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

7377

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

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

78+isolateGitProc :: ProcessSpec -> ProcessSpec

79+isolateGitProc = setEnvOverride (overrides <>)

80+ where

81+ overrides = M.fromList

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

83+ , ("GIT_CONFIG_NOSYSTEM", "1")

84+ , ("GIT_TERMINAL_PROMPT", "0")

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

86+ ]

87+

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

89+copyDir :: FilePath -> FilePath -> ProcessSpec

7690copyDir src dest =

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

91+ setCwd (Just src) $ proc cp ["-a", ".", dest] -- TODO: This will break if dest is relative since we change cwd

7892

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

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

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

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

88102

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

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

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

91105runProc = callProcessAndLogOutput (Notice, Error)

92106

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

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

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

95109runProcSilently = callProcessAndLogOutput (Debug, Debug)

96110

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

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

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

99113readProc = readProcessAndLogOutput (Debug, Error)

100114

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

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

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

130144 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

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

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

133− Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo $

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

147+ Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo

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

135149 let t = T.pack out

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

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

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

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

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

140154 pure (exitCode, maps)

141155

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/obelisk-selftest.cabal+4−2

@@ -11,16 +11,18 @@ library

1111 base

1212 , containers

1313 , directory

14+ , filepath

1415 , hspec

1516 , http-client

1617 , http-types

1718 , HUnit

19+ , network

1820 , obelisk-cliapp

1921 , obelisk-executable-config-lookup

2022 , obelisk-run

23+ , which

2124 , process

22− , network

23− , shelly

25+ , shelly >= 1.9.0

2426 , temporary

2527 , text

2628 exposed-modules:

lib/selftest/src/Obelisk/SelfTest.hs+101−45

@@ -3,6 +3,8 @@

33{-# LANGUAGE OverloadedStrings #-}

44{-# LANGUAGE PatternGuards #-}

55{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE ViewPatterns #-}

7+{-# LANGUAGE TemplateHaskell #-}

68module Obelisk.SelfTest where

810import Control.Exception (bracket, throw)

@@ -10,7 +12,7 @@ import Control.Monad

1012import Control.Monad.IO.Class

1113import Data.Bool (bool)

1214import Data.Function (fix)

13−import Data.Semigroup (Semigroup, (<>))

15+import Data.Semigroup ((<>))

1416import qualified Data.Set as Set

1517import Data.String

1618import Data.Text (Text)

@@ -20,11 +22,13 @@ import qualified Data.Text.IO as T

2022import qualified Network.HTTP.Client as HTTP

2123import qualified Network.HTTP.Types as HTTP

2224import qualified Network.Socket as Socket

23−import Shelly

25+import Shelly hiding (cp)

2426import System.Directory (withCurrentDirectory, getDirectoryContents)

2527import System.Environment

2628import System.Exit (ExitCode (..))

27−import System.Info

29+import System.FilePath (replaceBaseName, takeBaseName)

30+import System.Which (staticWhich)

31+import qualified System.Info

2832import System.IO (Handle, hClose)

2933import System.IO.Temp

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

@@ -42,16 +46,21 @@ data ObRunState

4246 | ObRunState_BackendStarted

4347 deriving (Eq, Show)

4448

45−doubleQuotes :: (IsString a, Semigroup a) => a -> a

46−doubleQuotes s = "\"" <> s <> "\""

49+cp :: FilePath

50+cp = $(staticWhich "cp")

51+

52+cabalPath :: FilePath

53+cabalPath = $(staticWhich "cabal")

54+

55+gitUserConfig :: [Text]

56+gitUserConfig = ["-c", "user.name=Obelisk Selftest", "-c", "user.email=noreply@example.com"]

4757

4858commit :: Text -> Sh ()

49−commit msg = void $ run "git"

50− [ "commit"

59+commit msg = void $ run "git" $ gitUserConfig <> [ "commit"

5160 , "--no-gpg-sign"

5261 , "--allow-empty"

5362 , "-m"

54− , doubleQuotes msg

63+ , msg

5564 ]

5665

5766-- TODO replace Void and stop using loosely typed synchronous exceptions

@@ -67,6 +76,7 @@ tshow = T.pack . show

6776shellyOb :: MonadIO m => (Sh a -> Sh a) -> Sh a -> m a

6877shellyOb f obTest = shelly $ f obTest

6978

79+

7080main :: IO ()

7181main = do

7282 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

@@ -75,25 +85,55 @@ main = do

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

7686 let verbosity = bool silently verbosely isVerbose

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

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

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

89+ let

90+ withObeliskImpl f =

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

92+ void . shellyOb verbosity $ chdir obeliskImpl $ do

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

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

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

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

97+ f obeliskImpl

98+

99+ withInitCache f obeliskImpl =

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

101+ -- Setup the ob init cache

102+ void . shellyOb verbosity $ chdir initCache $ do

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

104+ run_ "git" ["init"]

105+

106+ f initCache

107+

108+ withObeliskImplAndInitCache f =

109+ withObeliskImpl $ \impl -> withInitCache (f impl) impl

110+

79111 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

80− [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"]

112+

113+ withObeliskImplAndInitCache $ \obeliskImpl initCache ->

86114 hspec $ parallel $ do

87115 let shelly_ = void . shellyOb verbosity

88116

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

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

117+ defaultTmpDirName = "test λ"

91118

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

119+ inTmp' :: FilePath -> (FilePath -> Sh a) -> IO ()

120+ inTmp' dirname f = withTmp' dirname (chdir <*> f)

121+ inTmp = inTmp' defaultTmpDirName

93122

94− inTmpObInit f = inTmp $ \dir -> do

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

123+ withTmp' dirname f = shelly_ . withSystemTempDirectory dirname $ f . fromString

124+ withTmp = withTmp' defaultTmpDirName

125+

126+ inTmpObInit' dirname f = inTmp' dirname $ \dir -> do

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

96128 f dir

129+ inTmpObInit = inTmpObInit' defaultTmpDirName

130+

131+ -- To be used in tests that change the obelisk impl directory

132+ inTmpObInitWithImplCopy f = inTmpObInit $ \dir ->

133+ withObeliskImpl $ \(fromString -> implCopy) -> do

134+ run_ "rm" [thunk]

135+ run_ "ln" ["-s", implCopy, thunk]

136+ f dir

97137

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

99139 assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b

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

115155 describe "ob init" $ parallel $ do

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

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

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

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

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

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

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

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

@@ -134,25 +174,28 @@ main = do

134174

135175 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

136176 -- when not run by 'nix-build --attr selftest'

137− describe "ob run" $ parallel $ do

138− it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir p0 p1 Nothing httpManager

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

177+ describe "ob run" $ {- NOT parallel $ -} do

178+ it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir Nothing httpManager

179+ it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir (Just "frontend") httpManager

180+ it "works with differently named cabal files" $ inTmpObInit $ \_ -> do

181+ changeCabalPackageName "backend/backend.cabal" "new-backend"

182+ testObRunInDir Nothing httpManager

140183

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

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

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

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

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

146189

147190 describe "blank initialized project" $ parallel $ do

148191

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

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

151194

152− if os == "darwin"

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

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

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

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

198+ let defaultNixPath = dir </> ("default.nix" :: FilePath)

156199 writefile defaultNixPath

157200 =<< T.replace

158201 "# config.android_sdk.accept_license = false;"

@@ -162,19 +205,24 @@ main = do

162205

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

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

169−

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

208+ shellName = "shells." <> compiler

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

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

211+ -- NOTE: We override the temporary directory name because cabal has a bug preventing new-build from working

212+ -- in a path that has unicode characters.

213+ it ("can build in " <> shellName) $ inTmpObInit' "test" $ \_ -> inShell $

214+ T.pack cabalPath <> " --version; " <> T.pack cabalPath <> " new-build --" <> T.pack compiler <> " all"

215+

216+ it "has idempotent thunk update" $ inTmpObInitWithImplCopy $ \_ -> do

217+ _ <- pack

171218 u <- update

172219 uu <- update

173220 assertRevEQ u uu

174221

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

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

223+ it "has thunk pack and unpack inverses" $ inTmpObInitWithImplCopy $ \_ -> do

177224

225+ _ <- pack

178226 e <- commitAll

179227 eu <- unpack

180228 eup <- pack

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

212260 testThunkPack $ fromText repo

213261

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

215− void unpack

216263 testThunkPack (dir </> thunk)

217264

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

@@ -233,11 +280,12 @@ main = do

233280

234281

235282-- | Run `ob run` in the given directory (maximum of one level deep)

236−testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()

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

283+testObRunInDir :: Maybe FilePath -> HTTP.Manager -> Sh ()

284+testObRunInDir mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do

285+ [p0, p1] <- liftIO $ getFreePorts 2

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

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

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

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

241289 firstUri <- handleObRunStdout httpManager stdout

242290 let newUri = uri p1

243291 when (firstUri == newUri) $ errorExit $

@@ -248,7 +296,7 @@ testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure ();

248296 then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri

249297 else exit 0

250298

251−testThunkPack :: Shelly.FilePath -> Sh ()

299+testThunkPack :: FilePath -> Sh ()

252300testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do

253301 let pack' = readProcessWithExitCode "ob" ["thunk", "pack", T.unpack $ toTextIgnore path'] ""

254302 ensureThunkPackFails q = liftIO $ pack' >>= \case

@@ -269,7 +317,7 @@ testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $

269317 liftIO $ T.hPutStrLn handle "test file" >> hClose handle

270318 ensureThunkPackFails "modified"

271319 -- Existing stashes

272− void $ git ["stash"]

320+ void $ git $ gitUserConfig <> [ "stash" ]

273321 ensureThunkPackFails "has stashes"

274322

275323-- | Blocks until a non-empty line is available

@@ -314,6 +362,14 @@ obRunCheck httpManager _stdout frontendUri = do

314362 req frontendUri >>= \r -> when (HTTP.responseStatus r /= HTTP.ok200) $ errorExit $

315363 "Request to frontend server failed: " <> T.pack (show r)

316364

365+-- | Rename a cabal file and do a really dumb, brittle search/replace in its content to update the name.

366+changeCabalPackageName :: FilePath -> Text -> Sh ()

367+changeCabalPackageName cabalFile newName = do

368+ contents <- readfile cabalFile

369+ writefile (replaceBaseName cabalFile (T.unpack newName)) $

370+ T.replace (" " <> T.pack (takeBaseName cabalFile)) (" " <> newName) contents -- WARNING: Super brittle

371+ rm cabalFile

372+

317373getFreePorts :: Int -> IO [Socket.PortNumber]

318374getFreePorts 0 = pure []

319375getFreePorts n = Socket.withSocketsDo $ do

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

release.nix+8−95

@@ -1,97 +1,10 @@

1−{ self-args ? {

2− config.android_sdk.accept_license = true;

3− iosSdkVersion = "10.2";

4− }

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

1+{

2+ supportedSystems ? [ "x86_64-linux" "x86_64-darwin" ]

63}:

4+rec {

5+ recurseForDerivations = true;

6+ build = import ./all-builds.nix { inherit supportedSystems; };

7+ test = import ./all-tests.nix { inherit supportedSystems; };

8−let

9− inherit (local-self.nixpkgs) lib runCommand nix;

10−

11− cacheBuildSystems = [ "x86_64-linux" "x86_64-darwin" ];

12−

13− obeliskPackagesCommon = [

14− "obelisk-frontend"

15− "obelisk-route"

16− "obelisk-executable-config-lookup"

17− ];

18−

19− obeliskPackagesBackend = obeliskPackagesCommon ++ [

20− "obelisk-asset-manifest"

21− "obelisk-asset-serve-snap"

22− "obelisk-backend"

23− "obelisk-cliapp"

24− "obelisk-command"

25− "obelisk-executable-config-inject"

26− "obelisk-frontend"

27− "obelisk-run"

28− "obelisk-route"

29− "obelisk-selftest"

30− "obelisk-snap-extras"

31− ];

32−

33− pnameToAttrs = pkgsSet: pnames:

34− lib.listToAttrs (map

35− (name: { inherit name; value = pkgsSet.${name}; })

36− pnames);

37−

38− concatDepends = let

39− extractDeps = x: (x.override {

40− mkDerivation = drv: {

41− out = builtins.concatLists [

42− (drv.buildDepends or [])

43− (drv.libraryHaskellDepends or [])

44− (drv.executableHaskellDepends or [])

45− ];

46− };

47− }).out;

48− in pkgAttrs: builtins.concatLists (map extractDeps (builtins.attrValues pkgAttrs));

49−

50− perPlatform = lib.genAttrs cacheBuildSystems (system: let

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

52− reflex-platform = obelisk.reflex-platform;

53− ghc = pnameToAttrs

54− obelisk.haskellPackageSets.ghc

55− obeliskPackagesBackend;

56− ghcjs = pnameToAttrs

57− obelisk.haskellPackageSets.ghcjs

58− obeliskPackagesCommon;

59− cachePackages = builtins.concatLists [

60− (builtins.attrValues ghc)

61− (builtins.attrValues ghcjs)

62− (concatDepends ghc)

63− (concatDepends ghcjs)

64− (lib.optional reflex-platform.androidSupport androidSkeleton)

65− (lib.optional reflex-platform.iosSupport iosSkeleton)

66− [ command serverSkeletonExe serverSkeletonShell ]

67− ];

68− command = obelisk.command;

69− skeleton = import ./skeleton { inherit obelisk; };

70− serverSkeletonExe = skeleton.exe;

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

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

73− touch "$out"

74− echo "return" >> "$out"

75− cat "${skeleton.shells.ghc}" >> "$out"

76− '';

77− androidSkeleton = (import ./skeleton { inherit obelisk; }).android.frontend;

78− iosSkeleton = (import ./skeleton { inherit obelisk; }).ios.frontend;

79− in {

80− inherit

81− command

82− ghc ghcjs

83− serverSkeletonExe

84− serverSkeletonShell

85− ;

86− cache = reflex-platform.pinBuildInputs "obelisk-${system}" cachePackages;

87− } // lib.optionalAttrs reflex-platform.androidSupport {

88− inherit androidSkeleton;

89− } // lib.optionalAttrs reflex-platform.iosSupport {

90− inherit iosSkeleton;

91− });

92−

93− metaCache = local-self.reflex-platform.pinBuildInputs

94− "obelisk-everywhere"

95− (map (a: a.cache) (builtins.attrValues perPlatform));

96−

97−in perPlatform // { inherit metaCache; }

9+ inherit (build) metaCache;

10+}

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/frontend.cabal+1

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

99 , common

1010 , obelisk-frontend

1111 , obelisk-route

12+ , jsaddle

1213 , reflex-dom

1314 , obelisk-executable-config-lookup

1415 , obelisk-generated-static

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

@@ -1,25 +1,43 @@

11{-# LANGUAGE DataKinds #-}

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE TypeApplications #-}

45module Frontend where

7+import Control.Monad

68import qualified Data.Text as T

79import qualified Data.Text.Encoding as T

10+import Language.Javascript.JSaddle (eval, liftJSM)

11+

812import Obelisk.Frontend

913import Obelisk.Configs

1014import Obelisk.Route

15+import Obelisk.Generated.Static

16+

1117import Reflex.Dom.Core

1218

1319import Common.Api

1420import Common.Route

15−import Obelisk.Generated.Static

1621

22+

23+-- This runs in a monad that can be run on the client or the server.

24+-- To run code in a pure client or pure server context, use one of the

25+-- `prerender` functions.

1726frontend :: Frontend (R FrontendRoute)

1827frontend = Frontend

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

28+ { _frontend_head = do

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

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

2031 , _frontend_body = do

21− text "Welcome to Obelisk!"

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

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

34+

35+ -- `prerender` and `prerender_` let you choose a widget to run on the server

36+ -- during prerendering and a different widget to run on the client with

37+ -- JavaScript. The following will generate a `blank` widget on the server and

38+ -- print "Hello, World!" on the client.

39+ prerender_ blank $ liftJSM $ void $ eval ("console.log('Hello, World!')" :: T.Text)

40+

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

2442 el "div" $ do

2543 exampleConfig <- getConfig "common/example"

skeleton/static/main.cssnew file+3

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

1+p {

2+ color: red;

3+}