2cea7df · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge branch 'master' into db

2cea7dfRyan Trinkle8 years ago

README.md+19−53

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

47When developing on obelisk itself you may launch `ghcid` for the corresponding project as follows. For example to launch ghcid for `lib/backend` project:

49```

50−nix-shell -A obelisk.obelisk-backend.env --run "cd lib/backend && ghcid -c 'cabal new-repl'"

50+nix-shell -A obeliskEnvs.obelisk-backend --run "cd lib/backend && ghcid -c 'cabal new-repl'"

51```

53Or to launch ghcid for `lib/command` project:

55```

56−nix-shell -A obelisk.obelisk-command.env --run "cd lib/command && ghcid -c 'cabal new-repl'"

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

57```

59### Accessing private repositories

60+

60−To allow the Nix builder to access private git repositories, follow these steps:

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

61−

62+to access them via SSH. Follow these steps depending on the platform you need

63+access to:

64+

62−1. [Get set up to connect to GitHub with SSH](https://help.github.com/articles/connecting-to-github-with-ssh/)

65+- [GitHub](https://help.github.com/articles/connecting-to-github-with-ssh/)

63−1. [Create a GitHub personal access token](https://help.github.com/articles/creating-a-personal-access-token-for-the-command-line/)

66+- [GitLab](https://docs.gitlab.com/ee/gitlab-basics/create-your-ssh-keys.html)

64−1. Set environment variables:

65− * NixOS: Add this to `/etc/nixos/configuration.nix`:

66− ```

67− nix.envVars = {

68− NIX_GITHUB_PRIVATE_USERNAME = "your-github-username";

69− NIX_GITHUB_PRIVATE_PASSWORD = "your-github-personal-access-token";

70− };

71− ```

72− * MacOS:

73− ```

74− sudo launchctl setenv NIX_GITHUB_PRIVATE_USERNAME "your-github-username"

75− sudo launchctl setenv NIX_GITHUB_PRIVATE_PASSWORD "your-github-personal-access"

76− sudo launchctl stop org.nixos.nix-daemon

77− sudo launchctl start org.nixos.nix-daemon

78− ```

79−1. `nix-env -i hub` OR `nix-env -iA nixos.gitAndTools.hub`

80−1. `hub clone yourusername/yourproject`

81− * NOTE: you must authenticate with hub at least once, because the `ob` command uses `hub` for authentication

82− #TODO: Make ob do this itself (either invoke hub automatically or not depend on hub)

84## Developing an Obelisk project

68## Developing an Obelisk project

@@ -156,7 +140,7 @@ ob deploy push

156

140

157`ob deploy push` will locally build your app and then transfer it, along with all the Nix package dependencies, via ssh to the EC2 instance. The backend will live in `/var/lib/backend`.

141`ob deploy push` will locally build your app and then transfer it, along with all the Nix package dependencies, via ssh to the EC2 instance. The backend will live in `/var/lib/backend`.

158

142

159−At this point you are done. Your app will be accessible at `${ROUTE}`.

143+At this point you are done. Your app will be accessible at `${ROUTE}`. The currently deployed version - the git commit hash of the source repo - can be found at `${ROUTE}/version`.

160

144

161### From macOS

145### From macOS

162

146

@@ -263,38 +247,20 @@ Now deploy the built apk file to your Android device:

2631. Connect the device using USB (be sure to confirm any security prompts on the device)

2471. Connect the device using USB (be sure to confirm any security prompts on the device)

2641. Run the deploy script: `result-android/bin/deploy`

2481. Run the deploy script: `result-android/bin/deploy`

265

249

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

250+Alternatively, you can deploy from an obelisk deployment directory (a directory generated post `ob deploy init ...` command) using the `ob deploy test android` command.

251+This command will accomplish the following:

267

252

268−#### Releasing to Play Store

253+1. Create a key store and apk signing key (`android_keystore.jks`)

254+1. Build a Signed Android apk for your application

255+1. Deploy the Signed apk to your connected Android device

269

256

270−##### Configure signing

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

271

258

272−The previous section would have generated a debug version of the app. In order to build a release version you will need to sign your app. Obelisk can automatically sign the app during build if you provide it with your keystore file in `default.nix`.

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

273

260

274−First, if you do not already have a keystore, create it as follows (for more information, see the [Android documentation](https://developer.android.com/studio/publish/app-signing#signing-manually)):

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

275−

276−```

277−nix-shell -p androidenv.platformTools --run "keytool -genkey -v -keystore myandroidkey.jks -keyalg RSA -keysize 2048 -validity 10000 -alias myandroidalias"

278−```

279−

280−(Be sure to give an appropriate keystore filename and key alias string above.)

281−

282−The `keytool` command will ask you for some details, including a keystore password and a key password (we will use these passwords further below). It will now have created a `myandroidkey.jks` file under the current directory. Move that to somewhere safe, and note down its full path.

283−

284−Now edit your project's `default.nix` and tell Obelisk of your app's keystore file. Your `default.nix` should look like this after the edit:

285

262

286−```nix

263+#### Releasing to Play Store

287− ...

288− android.applicationId = "com.example.myapp";

289− android.displayName = "My App";

290− android.releaseKey =

291− { storeFile = /path/to/myandroidkey.jks;

292− storePassword = "abcd1234";

293− keyAlias = "myandroidalias";

294− keyPassword = "abcd1234";

295− };

296− ...

297−```

298

264

299##### Build a release version

265##### Build a release version

300

266

default.nix+41−22

@@ -12,7 +12,6 @@ let

12 commandRuntimeDeps = pkgs: with pkgs; [

13 coreutils

14 git

15− gitAndTools.hub

16 nix-prefetch-git

15 nix-prefetch-git

17 openssh

16 openssh

18 ];

17 ];

@@ -49,6 +48,12 @@ let

49 (self: super: let

48 (self: super: let

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

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

51 in {

50 in {

51+ hnix = pkgs.haskell.lib.dontCheck (self.callCabal2nix "hnix" (pkgs.fetchFromGitHub {

52+ owner = "haskell-nix";

53+ repo = "hnix";

54+ rev = "42afdc21da5d9e076eab57eaa42bfdde938192b8";

55+ sha256 = "0psw384dx9bw2dp93xrzw8rd9amvcwgzn64jzzwby7sfspj6k349";

56+ }) {});

52 # Need 8.0.2 build support

57 # Need 8.0.2 build support

53 # PR: https://github.com/dmwit/universe/pull/33

58 # PR: https://github.com/dmwit/universe/pull/33

54 universe-template = self.callCabal2nix "universe-template" (pkgs.fetchFromGitHub {

59 universe-template = self.callCabal2nix "universe-template" (pkgs.fetchFromGitHub {

@@ -111,7 +116,6 @@ let

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

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

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

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

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

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

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

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

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

116 })

120 })

117

121

@@ -141,9 +145,11 @@ let

141 in {

145 in {

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

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

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

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

148+ obelisk-command = haskellLib.overrideCabal

144− obelisk-command = (addOptparseApplicativeCompletionScripts "ob"

149+ (addOptparseApplicativeCompletionScripts "ob"

145− (haskellLib.justStaticExecutables super.obelisk-command)).overrideAttrs (drv: {

150+ (haskellLib.justStaticExecutables super.obelisk-command))

146− buildInputs = drv.buildInputs ++ [ pkgs.makeWrapper ];

151+ (drv: {

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

147 postFixup = ''

153 postFixup = ''

148 ${drv.postFixup or ""}

154 ${drv.postFixup or ""}

149 # Make `ob` reference its runtime dependencies.

155 # Make `ob` reference its runtime dependencies.

@@ -163,6 +169,9 @@ let

163 # The haskell environment used to build Obelisk itself, e.g. the 'ob' command

169 # The haskell environment used to build Obelisk itself, e.g. the 'ob' command

164 ghcObelisk = reflex-platform.ghc;

170 ghcObelisk = reflex-platform.ghc;

165

171

172+ # Development environments for obelisk packages.

173+ ghcObeliskEnvs = pkgs.lib.mapAttrs (n: v: reflex-platform.workOn ghcObelisk v) ghcObelisk;

174+

166 inherit (import ./lib/asset/assets.nix { inherit nixpkgs; }) mkAssets;

175 inherit (import ./lib/asset/assets.nix { inherit nixpkgs; }) mkAssets;

167

176

168 haskellLib = pkgs.haskell.lib;

177 haskellLib = pkgs.haskell.lib;

@@ -174,6 +183,7 @@ in rec {

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

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

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

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

176 obelisk = ghcObelisk;

185 obelisk = ghcObelisk;

186+ obeliskEnvs = ghcObeliskEnvs;

177 command = ghcObelisk.obelisk-command;

187 command = ghcObelisk.obelisk-command;

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

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

179

189

@@ -183,7 +193,7 @@ in rec {

183

193

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

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

185 export OBELISK_IMPL="${hackGet ./.}"

195 export OBELISK_IMPL="${hackGet ./.}"

186− "${ghcObelisk.obelisk-selftest}/bin/obelisk-selftest" "$@"

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

187 '';

197 '';

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

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

189 skeleton = pkgs.runCommand "skeleton" {

199 skeleton = pkgs.runCommand "skeleton" {

@@ -196,20 +206,19 @@ in rec {

196 processAssets = { src, packageName ? "obelisk-generated-static", moduleName ? "Obelisk.Generated.Static" }: pkgs.runCommand "asset-manifest" {

206 processAssets = { src, packageName ? "obelisk-generated-static", moduleName ? "Obelisk.Generated.Static" }: pkgs.runCommand "asset-manifest" {

197 inherit src;

207 inherit src;

198 outputs = [ "out" "haskellManifest" "symlinked" ];

208 outputs = [ "out" "haskellManifest" "symlinked" ];

199− buildInputs = [

209+ nativeBuildInputs = [ ghcObelisk.obelisk-asset-manifest ];

200− (reflex-platform.ghc.callCabal2nix "obelisk-asset-manifest" (hackGet ./lib/asset + "/manifest") {})

201− ];

202 } ''

210 } ''

203 set -euo pipefail

211 set -euo pipefail

204 touch "$out"

212 touch "$out"

213+ mkdir -p "$symlinked"

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

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

206 '';

215 '';

207

216

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

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

209 mkdir $out

218 mkdir $out

210 cd $out

219 cd $out

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

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

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

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

213 echo "//# sourceMappingURL=all.js.map" >> all.js

222 echo "//# sourceMappingURL=all.js.map" >> all.js

214 '';

223 '';

215

224

@@ -280,17 +289,18 @@ in rec {

280 };

289 };

281 };

290 };

282

291

283− serverExe = backend: frontend: assets: config:

292+ serverExe = backend: frontend: assets: config: optimizationLevel: version:

284 pkgs.runCommand "serverExe" {} ''

293 pkgs.runCommand "serverExe" {} ''

285 mkdir $out

294 mkdir $out

286 set -eux

295 set -eux

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

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

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

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

289 cp -r ${config} $out/config

298 cp -r ${config} $out/config

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

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

300+ echo ${version} > $out/version

291 '';

301 '';

292

302

293− server = { exe, hostName, adminEmail, routeHost, enableHttps, config }@args:

303+ server = { exe, hostName, adminEmail, routeHost, enableHttps, config, version }@args:

294 let

304 let

295 nixos = import (pkgs.path + /nixos);

305 nixos = import (pkgs.path + /nixos);

296 in nixos {

306 in nixos {

@@ -316,11 +326,13 @@ in rec {

316 , tools ? _: []

326 , tools ? _: []

317 , shellToolOverrides ? _: _: {}

327 , shellToolOverrides ? _: _: {}

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

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

329+ , __closureCompilerOptimizationLevel ? "ADVANCED"

319 }:

330 }:

320 let frontendName = "frontend";

331 let frontendName = "frontend";

321 backendName = "backend";

332 backendName = "backend";

322 commonName = "common";

333 commonName = "common";

323 staticName = "obelisk-generated-static";

334 staticName = "obelisk-generated-static";

335+ staticFilesImpure = if lib.isDerivation staticFiles then staticFiles else toString staticFiles;

324 processedStatic = processAssets { src = staticFiles; };

336 processedStatic = processAssets { src = staticFiles; };

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

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

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

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

@@ -344,7 +356,7 @@ in rec {

344 overrides = totalOverrides;

356 overrides = totalOverrides;

345 packages = combinedPackages;

357 packages = combinedPackages;

346 shells = {

358 shells = {

347− ghcSavedSplices = (lib.filter (x: lib.hasAttr x combinedPackages) [

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

348 commonName

360 commonName

349 frontendName

361 frontendName

350 ]);

362 ]);

@@ -372,21 +384,28 @@ in rec {

372 nixpkgs.obeliskExecutableConfig.platforms.ios.inject injectableConfig processedStatic.symlinked;

384 nixpkgs.obeliskExecutableConfig.platforms.ios.inject injectableConfig processedStatic.symlinked;

373 } // ios;

385 } // ios;

374 };

386 };

375− passthru = { inherit android ios packages overrides tools shellToolOverrides withHoogle staticFiles; };

387+ passthru = { inherit android ios packages overrides tools shellToolOverrides withHoogle staticFiles staticFilesImpure __closureCompilerOptimizationLevel; };

376 };

388 };

377 in mkProject (projectDefinition args));

389 in mkProject (projectDefinition args));

390+ serverOn = sys: config: version: serverExe

391+ (projectOut sys).ghc.backend

392+ (projectOut system).ghcjs.frontend

378− serverOn = sys: config: serverExe (projectOut sys).ghc.backend (projectOut system).ghcjs.frontend (projectOut sys).passthru.staticFiles config;

393+ (projectOut sys).passthru.staticFiles

394+ config

395+ (projectOut sys).passthru.__closureCompilerOptimizationLevel

396+ version;

379 linuxExe = serverOn "x86_64-linux";

397 linuxExe = serverOn "x86_64-linux";

398+ dummyVersion = "Version number is only available for deployments";

380 in projectOut system // {

399 in projectOut system // {

381 linuxExeConfigurable = linuxExe;

400 linuxExeConfigurable = linuxExe;

382− linuxExe = linuxExe (base + "/config");

401+ linuxExe = linuxExe (base + "/config") dummyVersion;

383− exe = serverOn system (base + "/config") ;

402+ exe = serverOn system (base + "/config") dummyVersion;

384− server = args@{ hostName, adminEmail, routeHost, enableHttps, config }: let

403+ server = args@{ hostName, adminEmail, routeHost, enableHttps, config, version }: let

385 injectableConfig = builtins.filterSource (path: _: !(lib.hasPrefix (toString config + "/backend") (toString path))) config;

404 injectableConfig = builtins.filterSource (path: _: !(lib.hasPrefix (toString config + "/backend") (toString path))) config;

386− in server (args // { exe = linuxExe injectableConfig; });

405+ in server (args // { exe = linuxExe injectableConfig version; });

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

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

388 };

407 };

389 haskellPackageSets = {

408 haskellPackageSets = {

390− inherit (reflex-platform) ghc;

409+ inherit (reflex-platform) ghc ghcjs;

391 };

410 };

392}

411}

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

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

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "bump-reflex-query-morphisms",

4+ "branch": "develop",

5− "rev": "ad70acfc3b731468ef0cd30717ea0d059b98ece9",

5+ "rev": "a7cd9a23e7faa9c2545a4c111229e28208e42351",

6− "sha256": "0122pxrq4vjrlrkkfp53jkyyl2gc4yrw8600jf4gcbxxv0dk8979"

6+ "sha256": "0y52rfrhk4zszgprpyni51l0pgq18dg695k5bmpd62c3zxar5mvm"

lib/asset/manifest/src-bin/generate.hs−1

@@ -12,6 +12,5 @@ main = do

12 writeStaticProject paths haskellTarget $ StaticConfig

13 { _staticConfig_packageName = T.pack packageName

14 , _staticConfig_moduleName = T.pack moduleName

15− , _staticConfig_rootPath = root

16 }

15 }

17 copyAndSymlink paths root fileTarget

16 copyAndSymlink paths root fileTarget

lib/asset/manifest/src/Obelisk/Asset/Promoted.hs+1−9

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

28data StaticConfig = StaticConfig

29 { _staticConfig_packageName :: Text --TODO: Better type

30 , _staticConfig_moduleName :: Text --TODO: Better type

31− , _staticConfig_rootPath :: FilePath

32 }

31 }

34writeStaticProject :: Map FilePath FilePath -> FilePath -> StaticConfig -> IO ()

33writeStaticProject :: Map FilePath FilePath -> FilePath -> StaticConfig -> IO ()

@@ -41,14 +40,7 @@ writeStaticProject paths target cfg = do

41 Just (name, parents) -> (name, target </> "src" </> T.unpack (T.intercalate "/" $ reverse parents))

40 Just (name, parents) -> (name, target </> "src" </> T.unpack (T.intercalate "/" $ reverse parents))

42 createDirectoryIfMissing True moduleDirPath

41 createDirectoryIfMissing True moduleDirPath

43 modContents <- staticModuleFile modName paths

42 modContents <- staticModuleFile modName paths

44− T.writeFile (moduleDirPath </> T.unpack modName' <.> "hs") $ appendRootPath (_staticConfig_rootPath cfg) modContents

43+ T.writeFile (moduleDirPath </> T.unpack modName' <.> "hs") modContents

45−

46−appendRootPath :: FilePath -> Text -> Text

47−appendRootPath fp txt = T.unlines

48− [ txt

49− , "staticRootPath :: FilePath"

50− , "staticRootPath = \"" <> T.pack fp <> "\""

51− ]

53staticCabalFile :: StaticConfig -> Text

45staticCabalFile :: StaticConfig -> Text

54staticCabalFile cfg = T.unlines

46staticCabalFile cfg = T.unlines

lib/backend/obelisk-backend.cabal+1−1

@@ -17,7 +17,7 @@ library

17 obelisk-executable-config-inject,

18 obelisk-frontend,

19 obelisk-route,

20− obelisk-snap,

20+ obelisk-snap-extras,

21 reflex-dom,

22 snap,

23 snap-server,

lib/backend/src/Obelisk/Backend.hs+36−16

@@ -5,6 +5,7 @@

5{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TemplateHaskell #-}

9{-# LANGUAGE TemplateHaskell #-}

9module Obelisk.Backend

10module Obelisk.Backend

10 ( Backend (..)

11 ( Backend (..)

@@ -16,6 +17,8 @@ module Obelisk.Backend

16 , serveDefaultObeliskApp

17 , serveDefaultObeliskApp

17 , prettifyOutput

18 , prettifyOutput

18 , runBackend

19 , runBackend

20+ , staticRenderContentType

21+ , mkRouteToUrl

19 ) where

22 ) where

21import Prelude hiding (id, (.))

24import Prelude hiding (id, (.))

@@ -29,6 +32,7 @@ import Data.Default (Default (..))

29import Data.Dependent.Sum

32import Data.Dependent.Sum

30import Data.Functor.Sum

33import Data.Functor.Sum

31import Data.Functor.Identity

34import Data.Functor.Identity

35+import Data.Monoid ((<>))

32import Data.Text (Text)

36import Data.Text (Text)

33import qualified Data.Text as T

37import qualified Data.Text as T

34import Data.Text.Encoding

38import Data.Text.Encoding

@@ -36,9 +40,10 @@ import Obelisk.Asset.Serve.Snap (serveAsset)

36import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)

40import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)

37import Obelisk.Frontend

41import Obelisk.Frontend

38import Obelisk.Route

42import Obelisk.Route

43+import Obelisk.Snap.Extras (doNotCache, serveFileIfExistsAs)

39import Reflex.Dom

44import Reflex.Dom

40−import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, httpServe, rqPathInfo,

45+import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, httpServe, modifyResponse

41− rqQueryString, writeBS, writeText)

46+ , rqPathInfo, rqQueryString, setContentType, writeBS, writeText)

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

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

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

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

@@ -55,8 +60,8 @@ data GhcjsApp route = GhcjsApp

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

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

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

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

58−serveDefaultObeliskApp :: MonadSnap m => ([Text] -> m ()) -> Frontend (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

63+serveDefaultObeliskApp :: MonadSnap m => (R appRoute -> Text) -> ([Text] -> m ()) -> Frontend (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

59−serveDefaultObeliskApp serveStaticAsset frontend = serveObeliskApp serveStaticAsset frontendApp

64+serveDefaultObeliskApp urlEnc serveStaticAsset frontend = serveObeliskApp urlEnc serveStaticAsset frontendApp

60 where frontendApp = GhcjsApp

65 where frontendApp = GhcjsApp

61 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets

66 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets

62 , _ghcjsApp_value = frontend

67 , _ghcjsApp_value = frontend

@@ -107,16 +112,17 @@ getRouteWith e = do

107 pageName <- getPageName

112 pageName <- getPageName

108 return $ tryDecode e pageName

113 return $ tryDecode e pageName

109

114

110−serveObeliskApp :: MonadSnap m => ([Text] -> m ()) -> GhcjsApp (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

115+serveObeliskApp :: MonadSnap m => (R appRoute -> Text) -> ([Text] -> m ()) -> GhcjsApp (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

111−serveObeliskApp serveStaticAsset frontendApp = \case

116+serveObeliskApp urlEnc serveStaticAsset frontendApp = \case

112− ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp frontendApp $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest

117+ ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc frontendApp $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest

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

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

114 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments

119 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments

115− ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp frontendApp $ GhcjsAppRoute_Resource :/ pathSegments

120+ ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc frontendApp $ GhcjsAppRoute_Resource :/ pathSegments

116 ResourceRoute_JSaddleWarp :=> Identity _ -> do

121 ResourceRoute_JSaddleWarp :=> Identity _ -> do

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

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

118 liftIO $ putStrLn $ T.unpack msg

123 liftIO $ putStrLn $ T.unpack msg

119 writeText msg

124 writeText msg

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

120

126

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

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

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

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

@@ -131,11 +137,15 @@ data GhcjsAppRoute :: (* -> *) -> * -> * where

131 GhcjsAppRoute_App :: appRouteComponent a -> GhcjsAppRoute appRouteComponent a

137 GhcjsAppRoute_App :: appRouteComponent a -> GhcjsAppRoute appRouteComponent a

132 GhcjsAppRoute_Resource :: GhcjsAppRoute appRouteComponent [Text]

138 GhcjsAppRoute_Resource :: GhcjsAppRoute appRouteComponent [Text]

133

139

140+staticRenderContentType :: ByteString

141+staticRenderContentType = "text/html; charset=utf-8"

142+

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

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

135−serveGhcjsApp :: MonadSnap m => GhcjsApp (R appRouteComponent) -> R (GhcjsAppRoute appRouteComponent) -> m ()

144+serveGhcjsApp :: MonadSnap m => (R appRouteComponent -> Text) -> GhcjsApp (R appRouteComponent) -> R (GhcjsAppRoute appRouteComponent) -> m ()

136−serveGhcjsApp app = \case

145+serveGhcjsApp urlEnc app = \case

137− GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest ->

146+ GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do

147+ modifyResponse $ setContentType staticRenderContentType

138− writeBS <=< liftIO $ renderGhcjsFrontend (appRouteComponent :/ appRouteRest) $ _ghcjsApp_value app

148+ writeBS <=< liftIO $ renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) $ _ghcjsApp_value app

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

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

140

150

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

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

@@ -146,10 +156,20 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend

146 getRouteWith validFullEncoder >>= \case

156 getRouteWith validFullEncoder >>= \case

147 Identity r -> case r of

157 Identity r -> case r of

148 InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

158 InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

159+ InR obeliskRoute :=> Identity a ->

149− InR obeliskRoute :=> Identity a -> serveDefaultObeliskApp (serveStaticAssets defaultStaticAssets) frontend $ obeliskRoute :/ a

160+ serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend $ obeliskRoute :/ a

161+

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

163+mkRouteToUrl validFullEncoder =

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

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

166+

150

167

151−renderGhcjsFrontend :: route -> Frontend route -> IO ByteString

168+renderGhcjsFrontend :: MonadIO m => (route -> Text) -> route -> Frontend route -> m ByteString

152−renderGhcjsFrontend route f = do

169+renderGhcjsFrontend urlEnc route f = do

153 let baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes

170 let baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes

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

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

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

173+ liftIO $ renderFrontendHtml urlEnc route

155− renderFrontendHtml route (_frontend_head f >> injectExecutableConfigs >> baseTag) (_frontend_body f >> ghcjsScript)

174+ (_frontend_head f >> injectExecutableConfigs >> baseTag >> ghcjsPreload)

175+ (_frontend_body f >> ghcjsScript)

lib/command/obelisk-command.cabal+2

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

23 , github

24 , here

25 , hit

26+ , hnix

26 , hpack

27 , hpack

27 , io-streams

28 , io-streams

28 , exceptions

29 , exceptions

@@ -43,6 +44,7 @@ library

43 , time

44 , time

44 , transformers

45 , transformers

45 , unix

46 , unix

47+ , unordered-containers

46 , yaml

48 , yaml

47 exposed-modules:

49 exposed-modules:

48 Obelisk.App

50 Obelisk.App

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

@@ -142,8 +142,8 @@ deployCommand cfg = hsubparser $ mconcat

142 ]

143 where

144 platformP = hsubparser $ mconcat

145− [ command "android" $ info (pure Android) mempty

145+ [ command "android" $ info (pure (Android, [])) mempty

146− , command "ios" $ info (pure IOS <*> strArgument (metavar "TEAMID" <> help "Your Team ID - found in the Apple developer portal")) mempty

146+ , command "ios" $ info ((,) <$> pure IOS <*> (fmap pure $ strArgument (metavar "TEAMID" <> help "Your Team ID - found in the Apple developer portal"))) mempty

147 ]

148

149 remoteBuilderParser :: Parser (Maybe RemoteBuilder)

@@ -173,16 +173,13 @@ deployInitOpts = DeployInitOpts

173 <*> flag True False (long "disable-https" <> help "Disable automatic https configuration for the backend")

174

175type TeamID = String

176−data PlatformDeployment = Android | IOS TeamID

177− deriving (Show)

178−

179data RemoteBuilder = RemoteBuilder_ObeliskVM

176data RemoteBuilder = RemoteBuilder_ObeliskVM

180 deriving (Eq, Show)

177 deriving (Eq, Show)

181

178

182data DeployCommand

179data DeployCommand

183 = DeployCommand_Init DeployInitOpts

180 = DeployCommand_Init DeployInitOpts

184 | DeployCommand_Push (Maybe RemoteBuilder)

181 | DeployCommand_Push (Maybe RemoteBuilder)

185− | DeployCommand_Test PlatformDeployment

182+ | DeployCommand_Test (PlatformDeployment, [String])

186 | DeployCommand_Update

183 | DeployCommand_Update

187 deriving Show

184 deriving Show

188

185

@@ -238,18 +235,10 @@ mkObeliskConfig = do

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

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

239 let logLevel = toLogLevel $ "-v" `elem` cliArgs

236 let logLevel = toLogLevel $ "-v" `elem` cliArgs

240 notInteractive <- not <$> isInteractiveTerm

237 notInteractive <- not <$> isInteractiveTerm

241−-- instance MonadIO m => MonadError (Either Text ProcessFailed) (DieT m) where

242−-- throwError = \case

243−-- Left s -> do

244−-- putLog Alert s

245−-- liftIO $ exitWith $ ExitFailure 2

246−-- Right (ProcessFailed p code) -> do

247−-- putLog Alert $ "Process exited with code " <> T.pack (show code) <> "; " <> T.pack (show p)

248−-- liftIO $ exitWith $ ExitFailure 2

249 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

238 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

250 ObeliskError_ProcessError (ProcessFailure p code) ann ->

239 ObeliskError_ProcessError (ProcessFailure p code) ann ->

251 ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p

240 ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p

252− <> maybe "" ("\n\n" <>) ann

241+ <> maybe "" ("\n" <>) ann

253 , 2

242 , 2

254 )

243 )

255 ObeliskError_Unstructured msg -> (msg, 2)

244 ObeliskError_Unstructured msg -> (msg, 2)

@@ -349,8 +338,7 @@ ob = \case

349 Nothing -> pure []

338 Nothing -> pure []

350 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg

339 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg

351 DeployCommand_Update -> deployUpdate "."

340 DeployCommand_Update -> deployUpdate "."

352− DeployCommand_Test Android -> deployMobile "android" []

341+ DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs

353− DeployCommand_Test (IOS teamID) -> deployMobile "ios" [teamID]

354 ObCommand_Run -> inNixShell' $ static run

342 ObCommand_Run -> inNixShell' $ static run

355 -- inNixShell ($(mkClosure 'ghcidAction) ())

343 -- inNixShell ($(mkClosure 'ghcidAction) ())

356 ObCommand_Thunk tc -> case tc of

344 ObCommand_Thunk tc -> case tc of

lib/command/src/Obelisk/Command/Deploy.hs+162−63

@@ -3,23 +3,34 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ViewPatterns #-}

6+{-# LANGUAGE DeriveGeneric #-}

7+{-# LANGUAGE TypeApplications #-}

6module Obelisk.Command.Deploy where

8module Obelisk.Command.Deploy where

8import Control.Lens

10import Control.Lens

9import Control.Monad

11import Control.Monad

10−import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try)

12+import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try, bracket_)

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

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

14+import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)

12import Data.Bits

15import Data.Bits

16+import qualified Data.ByteString.Lazy as BSL

13import Data.Default

17import Data.Default

18+import qualified Data.HashMap.Strict as HM

14import qualified Data.Map as Map

19import qualified Data.Map as Map

15−import Data.Maybe

20+import Data.Text (Text)

21+import qualified Data.Set as Set

16import qualified Data.Text as T

22import qualified Data.Text as T

17import qualified Data.Text.IO as T

23import qualified Data.Text.IO as T

24+import GHC.Generics

25+import Nix.Convert

26+import Nix.Pretty

27+import Nix.Value

18import System.Directory

28import System.Directory

19import System.Environment (getEnvironment)

29import System.Environment (getEnvironment)

20import System.FilePath

30import System.FilePath

31+import System.IO

21import System.Posix.Files

32import System.Posix.Files

22−import System.Process (delegate_ctlc, env, proc)

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

23import Text.URI (URI)

34import Text.URI (URI)

24import qualified Text.URI as URI

35import qualified Text.URI as URI

25import Text.URI.Lens

36import Text.URI.Lens

@@ -82,71 +93,65 @@ setupObeliskImpl deployDir = do

83deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()

94deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()

84deployPush deployPath getNixBuilders = do

95deployPush deployPath getNixBuilders = do

85− host <- readDeployConfig deployPath "backend_hosts"

96+ hosts <- Set.fromList . filter (/= mempty) . lines <$> readDeployConfig deployPath "backend_hosts"

86 adminEmail <- readDeployConfig deployPath "admin_email"

97 adminEmail <- readDeployConfig deployPath "admin_email"

87 enableHttps <- read <$> readDeployConfig deployPath "enable_https"

98 enableHttps <- read <$> readDeployConfig deployPath "enable_https"

88 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"

99 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"

89 routeHost <- getHostFromRoute enableHttps route

100 routeHost <- getHostFromRoute enableHttps route

90 let srcPath = deployPath </> "src"

101 let srcPath = deployPath </> "src"

91− build = do

92− builders <- getNixBuilders

93− buildOutput <- nixBuild $ def

94− { _nixBuildConfig_target = Target

95− { _target_path = srcPath

96− , _target_attr = Just "server.system"

97− }

98− , _nixBuildConfig_outLink = OutLink_None

99− , _nixBuildConfig_args =

100− [ strArg "hostName" host

101− , strArg "adminEmail" adminEmail

102− , strArg "routeHost" routeHost

103− , boolArg "enableHttps" enableHttps

104− , rawArg "config" $ deployPath </> "config"

105− ]

106− , _nixBuildConfig_builders = builders

107− }

108− return $ listToMaybe $ lines buildOutput

109− result <- readThunk srcPath >>= \case

102+ thunkPtr <- readThunk srcPath >>= \case

110− Right (ThunkData_Packed _) ->

103+ Right (ThunkData_Packed ptr) -> return ptr

111− build

112 Right (ThunkData_Checkout _) -> do

104 Right (ThunkData_Checkout _) -> do

113 checkGitCleanStatus srcPath True >>= \case

105 checkGitCleanStatus srcPath True >>= \case

114− True -> do

115− result <- build

116− packThunk srcPath

106+ True -> packThunk srcPath

117− return result

118− False -> do

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

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

120− return Nothing

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

121− _ -> return Nothing

109+ let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr

122− forM_ result $ \res -> do

110+ builders <- getNixBuilders

111+ buildOutputByHost <- ifor (Map.fromSet (const ()) hosts) $ \host () -> do

112+ --TODO: What does it mean if this returns more or less than 1 line of output?

113+ [result] <- fmap lines $ nixCmd $ NixCmd_Build $ def

114+ & nixCmdConfig_target .~ Target

115+ { _target_path = Just srcPath

116+ , _target_attr = Just "server.system"

117+ , _target_expr = Nothing

118+ }

119+ & nixBuildConfig_outLink .~ OutLink_None

120+ & nixCmdConfig_args .~

121+ [ strArg "hostName" host

122+ , strArg "adminEmail" adminEmail

123+ , strArg "routeHost" routeHost

124+ , strArg "version" version

125+ , boolArg "enableHttps" enableHttps

126+ , rawArg "config" $ deployPath </> "config"

127+ ]

128+ & nixCmdConfig_builders .~ builders

129+ pure result

123− let knownHostsPath = deployPath </> "backend_known_hosts"

130+ let knownHostsPath = deployPath </> "backend_known_hosts"

124− sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False

131+ sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False

125− deployAndSwitch outputPath = do

126− withSpinner "Uploading closure" $ do

132+ withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host outputPath -> do

127− callProcess'

133+ callProcess'

128− (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])

134+ (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])

129− "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]

135+ "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]

130−

136+ --TODO: Create GC root so we're sure our closure won't go away during this time period

131− withSpinner "Switching to new configuration" $ do

137+ withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do

132− callProcessAndLogOutput (Notice, Warning) $

138+ callProcessAndLogOutput (Notice, Warning) $

133− proc "ssh" $ sshOpts <>

139+ proc "ssh" $ sshOpts <>

134− [ "root@" <> host

140+ [ "root@" <> host

135− , unwords

141+ , unwords

136− [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath

142+ [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath

137− , "&&"

143+ , "&&"

138− , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"

144+ , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"

139− ]

145+ ]

140− ]

146+ ]

141− deployAndSwitch res

142− isClean <- checkGitCleanStatus deployPath True

147+ isClean <- checkGitCleanStatus deployPath True

143− when (not isClean) $ do

148+ when (not isClean) $ do

144− withSpinner "Commiting changes to Git" $ do

149+ withSpinner "Commiting changes to Git" $ do

145− callProcessAndLogOutput (Debug, Error) $ proc "git"

150+ callProcessAndLogOutput (Debug, Error) $ proc "git"

146− ["-C", deployPath, "add", "."]

151+ ["-C", deployPath, "add", "."]

147− callProcessAndLogOutput (Debug, Error) $ proc "git"

152+ callProcessAndLogOutput (Debug, Error) $ proc "git"

148− ["-C", deployPath, "commit", "-m", "New deployment"]

153+ ["-C", deployPath, "commit", "-m", "New deployment"]

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

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

150 where

155 where

151 callProcess' envMap cmd args = do

156 callProcess' envMap cmd args = do

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

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

@@ -156,13 +161,106 @@ deployPush deployPath getNixBuilders = do

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

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

157deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"

162deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"

158

163

164+keytoolToAndroidConfig :: KeytoolConfig -> HM.HashMap Text (NValueNF Identity)

165+keytoolToAndroidConfig conf = runIdentity $ do

166+ path <- toValue $ Path $ _keytoolConfig_keystore conf

167+ storepass <- toValue $ T.pack $ _keytoolConfig_storepass conf

168+ alias <- toValue $ T.pack $ _keytoolConfig_alias conf

169+ keypass <- toValue $ T.pack $ _keytoolConfig_keypass conf

170+ return $ HM.fromList

171+ [ ("storeFile", path)

172+ , ("storePassword", storepass)

173+ , ("keyAlias", alias)

174+ , ("keyPassword", keypass)

175+ ]

176+

177+data PlatformDeployment = Android | IOS

178+ deriving (Show, Eq)

179+

180+renderPlatformDeployment :: PlatformDeployment -> String

181+renderPlatformDeployment = \case

182+ Android -> "android"

183+ IOS -> "ios"

184+

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

185+deployMobile :: MonadObelisk m => PlatformDeployment -> [String] -> m ()

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

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

161 let srcDir = root </> "src"

187 let srcDir = root </> "src"

162 exists <- liftIO $ doesDirectoryExist srcDir

188 exists <- liftIO $ doesDirectoryExist srcDir

163 unless exists $ failWith "ob test should be run inside of a deploy directory"

189 unless exists $ failWith "ob test should be run inside of a deploy directory"

164− result <- nixBuildAttrWithCache srcDir $ platform <> ".frontend"

190+ nixBuildTarget <- case platform of

191+ Android -> do

192+ let keystorePath = root </> "android_keystore.jks"

193+ keytoolConfPath = root </> "android_keytool_config.json"

194+ hasKeystore <- liftIO $ doesFileExist keystorePath

195+ when (not hasKeystore) $ do

196+ -- TODO log instructions for how to modify the keystore

197+ putLog Notice $ "Creating keystore: " <> T.pack keystorePath

198+ putLog Notice "Enter a keystore password: "

199+ keyStorePassword <- liftIO $ withEcho False getLine

200+ putLog Notice "Re-enter the keystore password: "

201+ keyStorePassword' <- liftIO $ withEcho False getLine

202+ unless (keyStorePassword' == keyStorePassword) $ failWith "passwords do not match"

203+ let keyToolConf = KeytoolConfig

204+ { _keytoolConfig_keystore = keystorePath

205+ , _keytoolConfig_alias = "obelisk"

206+ , _keytoolConfig_storepass = keyStorePassword

207+ , _keytoolConfig_keypass = keyStorePassword

208+ }

209+ createKeystore root $ keyToolConf

210+ liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

211+ checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

212+ unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

213+ keytoolConfContents <- liftIO $ BSL.readFile keytoolConfPath

214+ liftIO $ putStrLn $ show keytoolConfContents

215+ releaseKey <- case eitherDecode keytoolConfContents of

216+ Left err -> failWith $ T.pack err

217+ Right conf -> do

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

219+ return $ printNix $ runIdentity nvset

220+ return $ Target

221+ { _target_path = Nothing

222+ , _target_attr = Nothing

223+ , _target_expr = Just $ "with (import " <> srcDir <> " {}); " <> renderPlatformDeployment platform <> ".frontend.override (drv: { releaseKey = (if builtins.isNull drv.releaseKey then {} else drv.releaseKey) // " <> releaseKey <> "; })"

224+ }

225+ IOS -> return $ Target

226+ { _target_path = Nothing

227+ , _target_attr = Just "ios.frontend"

228+ , _target_expr = Nothing

229+ }

230+ result <- nixCmd $ NixCmd_Build $ def

231+ & nixBuildConfig_outLink .~ OutLink_None

232+ & nixCmdConfig_target .~ nixBuildTarget

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

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

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

235+ where

236+ withEcho showEcho f = do

237+ prevEcho <- hGetEcho stdin

238+ bracket_ (hSetEcho stdin showEcho) (hSetEcho stdin prevEcho) f

239+

240+data KeytoolConfig = KeytoolConfig

241+ { _keytoolConfig_keystore :: FilePath

242+ , _keytoolConfig_alias :: String

243+ , _keytoolConfig_storepass :: String

244+ , _keytoolConfig_keypass :: String

245+ } deriving (Show, Generic)

246+

247+instance FromJSON KeytoolConfig

248+instance ToJSON KeytoolConfig

249+

250+createKeystore :: MonadObelisk m => FilePath -> KeytoolConfig -> m ()

251+createKeystore root config = do

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

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

254+ where

255+ keytoolCmd = processToShellString "keytool"

256+ [ "-genkeypair", "-noprompt"

257+ , "-keystore", _keytoolConfig_keystore config

258+ , "-keyalg", "RSA", "-keysize", "2048"

259+ , "-validity", "1000000000"

260+ , "-storepass", _keytoolConfig_storepass config

261+ , "-alias", _keytoolConfig_alias config

262+ , "-keypass", _keytoolConfig_keypass config

263+ ]

166

264

167-- | Simplified deployment configuration mechanism. At one point we may revisit this.

265-- | Simplified deployment configuration mechanism. At one point we may revisit this.

168writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()

266writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()

@@ -177,6 +275,7 @@ verifyHostKey knownHostsPath keyPath hostName =

177 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $

275 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $

178 sshArgs knownHostsPath keyPath True <>

276 sshArgs knownHostsPath keyPath True <>

179 [ "root@" <> hostName

277 [ "root@" <> hostName

278+ , "-o", "NumberOfPasswordPrompts=0"

180 , "exit"

279 , "exit"

181 ]

280 ]

182

281

lib/command/src/Obelisk/Command/Nix.hs+114−69

@@ -6,11 +6,19 @@

6{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE Rank2Types #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TemplateHaskell #-}

9{-# LANGUAGE TypeApplications #-}

10{-# LANGUAGE TypeApplications #-}

10module Obelisk.Command.Nix

11module Obelisk.Command.Nix

11− ( nixBuild

12+ ( nixCmd

12− , withNixRemoteCheck

13+ , NixCmd (..)

14+ , nixCmdConfig_target

15+ , nixCmdConfig_args

16+ , nixCmdConfig_builders

13 , NixBuildConfig (..)

17 , NixBuildConfig (..)

18+ , nixBuildConfig_outLink

19+ , NixInstantiateConfig (..)

20+ , nixInstantiateConfig_eval

21+ , NixCommonConfig (..)

14 , Target (..)

22 , Target (..)

15 , OutLink (..)

23 , OutLink (..)

16 , Arg (..)

24 , Arg (..)

@@ -19,41 +27,33 @@ module Obelisk.Command.Nix

19 , strArg

27 , strArg

20 ) where

28 ) where

22−--import Control.Monad.Catch (catch, throwM)

30+import Control.Monad (guard)

23import Control.Lens

31import Control.Lens

24−import Control.Monad.Except (ExceptT, runExceptT, throwError)

32+

25−import Control.Monad.IO.Class (liftIO)

26import Data.Bool (bool)

33import Data.Bool (bool)

27import Data.Default

34import Data.Default

28import Data.List (intercalate)

35import Data.List (intercalate)

36+import Data.Maybe

29import Data.Monoid ((<>))

37import Data.Monoid ((<>))

30import qualified Data.Text as T

38import qualified Data.Text as T

31−import System.Directory

32−import System.Environment

33import System.Process (proc)

39import System.Process (proc)

35−import Obelisk.App (MonadInfallibleObelisk, MonadObelisk, ObeliskError (..))

41+import Obelisk.App (MonadObelisk)

36import Obelisk.CliApp

42import Obelisk.CliApp

38−-- | Where to put nix-build output

39−data OutLink

40− = OutLink_Default

41− | OutLink_None

42− | OutLink_IndirectRoot FilePath

43−

44−instance Default OutLink where

45− def = OutLink_Default

46−

47-- | What to build

44-- | What to build

48data Target = Target

45data Target = Target

49− { _target_path :: FilePath

46+ { _target_path :: Maybe FilePath

50 , _target_attr :: Maybe String

47 , _target_attr :: Maybe String

48+ , _target_expr :: Maybe String

51 }

49 }

50+makeClassy ''Target

53instance Default Target where

52instance Default Target where

54 def = Target

53 def = Target

55− { _target_path = "."

54+ { _target_path = Just "."

56 , _target_attr = Nothing

55 , _target_attr = Nothing

56+ , _target_expr = Nothing

57 }

59data Arg

@@ -75,64 +75,109 @@ cliFromArgs = concatMap $ \case

75 Arg_Str k v -> ["--argstr", k, v]

76 Arg_Expr k v -> ["--arg", k, v]

78−data NixBuildConfig = NixBuildConfig

78+data NixCommonConfig = NixCommonConfig

79− { _nixBuildConfig_target :: Target

79+ { _nixCmdConfig_target :: Target

80− , _nixBuildConfig_outLink :: OutLink

80+ , _nixCmdConfig_args :: [Arg]

81− , _nixBuildConfig_args :: [Arg]

81+ , _nixCmdConfig_builders :: [String]

82− , _nixBuildConfig_builders :: [String]

83 }

82 }

83+makeClassy ''NixCommonConfig

85−instance Default NixBuildConfig where

85+instance Default NixCommonConfig where

86− def = NixBuildConfig def def mempty mempty

86+ def = NixCommonConfig def mempty mempty

88−nixBuild :: MonadObelisk m => NixBuildConfig -> m FilePath

88+runNixCommonConfig :: NixCommonConfig -> [FilePath]

89−nixBuild cfg = withSpinner' ("Running nix-build on " <> desc) (Just $ const $ "Built " <> desc) $ do

90− output <- withNixRemoteCheck $ readProcessAndLogStderr Debug $ proc "nix-build" $ mconcat

91− [[path], attrArg, args, outLink, buildersArg]

89+runNixCommonConfig cfg = mconcat [maybeToList path, attrArg, exprArg, args, buildersArg]

92− -- Remove final newline that Nix appends

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

94− pure $ T.unpack outPath

95 where

90 where

96− path = _target_path $ _nixBuildConfig_target cfg

91+ path = _target_path $ _nixCmdConfig_target cfg

97− attr = _target_attr $ _nixBuildConfig_target cfg

92+ attr = _target_attr $ _nixCmdConfig_target cfg

93+ expr = _target_expr $ _nixCmdConfig_target cfg

98 attrArg = case attr of

94 attrArg = case attr of

99 Nothing -> []

95 Nothing -> []

100 Just a -> ["-A", a]

96 Just a -> ["-A", a]

97+ exprArg = case expr of

98+ Nothing -> []

99+ Just a -> ["-E", a]

101− args = cliFromArgs $ _nixBuildConfig_args cfg

100+ args = cliFromArgs $ _nixCmdConfig_args cfg

101+ buildersArg = case _nixCmdConfig_builders cfg of

102+ [] -> []

103+ builders -> ["--builders", intercalate ";" builders]

104+

105+-- | Where to put nix-build output

106+data OutLink

107+ = OutLink_Default

108+ | OutLink_None

109+ | OutLink_IndirectRoot FilePath

110+

111+instance Default OutLink where

112+ def = OutLink_Default

113+

114+data NixBuildConfig = NixBuildConfig

115+ { _nixBuildConfig_common :: NixCommonConfig

116+ , _nixBuildConfig_outLink :: OutLink

117+ }

118+makeLenses ''NixBuildConfig

119+

120+instance HasNixCommonConfig NixBuildConfig where

121+ nixCommonConfig = nixBuildConfig_common

122+

123+instance Default NixBuildConfig where

124+ def = NixBuildConfig def def

125+

126+runNixBuildConfig :: NixBuildConfig -> [FilePath]

127+runNixBuildConfig cfg = mconcat

128+ [ runNixCommonConfig $ cfg ^. nixCommonConfig

102− outLink = case _nixBuildConfig_outLink cfg of

129+ , case _nixBuildConfig_outLink cfg of

103 OutLink_Default -> []

130 OutLink_Default -> []

104 OutLink_None -> ["--no-out-link"]

131 OutLink_None -> ["--no-out-link"]

105 OutLink_IndirectRoot l -> ["--out-link", l]

132 OutLink_IndirectRoot l -> ["--out-link", l]

106− desc = T.pack $ path <> maybe "" (\a -> " [" <> a <> "]") attr

133+ ]

107− buildersArg = case _nixBuildConfig_builders cfg of

134+

108− [] -> []

135+data NixInstantiateConfig = NixInstantiateConfig

109− builders -> ["--builders", intercalate ";" builders]

136+ { _nixInstantiateConfig_common :: NixCommonConfig

137+ , _nixInstantiateConfig_eval :: Bool

138+ }

139+makeLenses ''NixInstantiateConfig

140+

141+instance HasNixCommonConfig NixInstantiateConfig where

142+ nixCommonConfig = nixInstantiateConfig_common

143+

144+instance Default NixInstantiateConfig where

145+ def = NixInstantiateConfig def False

146+

147+runNixInstantiateConfig :: NixInstantiateConfig -> [FilePath]

148+runNixInstantiateConfig cfg = mconcat

149+ [ runNixCommonConfig $ cfg ^. nixCommonConfig

150+ , "--eval" <$ guard (_nixInstantiateConfig_eval cfg)

151+ ]

152+

153+data NixCmd

154+ = NixCmd_Build NixBuildConfig

155+ | NixCmd_Instantiate NixInstantiateConfig

156+

157+instance Default NixCmd where

158+ def = NixCmd_Build def

159+

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

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

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

163+ -- Remove final newline that Nix appends

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

165+ pure $ T.unpack outPath

166+ where

167+ (cmd, options, commonCfg) = case cmdCfg of

168+ NixCmd_Build cfg' ->

169+ ( "nix-build"

170+ , runNixBuildConfig cfg'

171+ , cfg' ^. nixCommonConfig

172+ )

173+ NixCmd_Instantiate cfg' ->

174+ ( "nix-instantiate"

175+ , runNixInstantiateConfig cfg'

176+ , cfg' ^. nixCommonConfig

177+ )

178+ path = commonCfg ^. nixCmdConfig_target . target_path

179+ desc = T.pack $ mconcat $ catMaybes

180+ [ (" on " <>) <$> path

181+ , (\a -> " [" <> a <> "]") <$> (commonCfg ^. nixCmdConfig_target . target_attr)

182+ ]

110

183

111−-- | If a nix command fails, and this may be related to the NIX_REMOTE issue,

112−-- tell the user what to do.

113−--

114−-- Added: June, 2018. Consider removing this eventually.

115−withNixRemoteCheck

116− :: MonadObelisk m

117− => (forall m'. MonadInfallibleObelisk m' => ExceptT ObeliskError m' a)

118− -> m a

119−withNixRemoteCheck f = do

120− status <- runExceptT f

121− case status of

122− Right a -> pure a

123− Left e -> throwError =<< case matching asProcessFailure e of

124− Left _ -> pure e

125− Right pf -> liftIO (lookupEnv "NIX_REMOTE") >>= \case

126− Just _ -> pure e

127− Nothing -> liftIO (writable <$> getPermissions "/nix/var/nix/db") >>= \case

128− True -> pure e

129− False -> pure $ ObeliskError_ProcessError pf $ Just $ T.unlines

130− [ "!!! "

131− , "!!! A nix command failed to run. You might need to set the NIX_REMOTE environment variable"

132− , "!!! to `daemon`. To do this, run the following before running obelisk:"

133− , "!!! "

134− , "!!! export NIX_REMOTE=daemon"

135− , "!!! "

136− , "!!! For details, see https://github.com/NixOS/nixpkgs/issues/5713"

137− , "!!! "

138− ]

lib/command/src/Obelisk/Command/Project.hs+2−3

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

34import Obelisk.App (MonadObelisk)

35import Obelisk.CliApp

36import Obelisk.Command.Thunk

37−import Obelisk.Command.Nix (withNixRemoteCheck)

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

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

40--TODO: Don't hardcode this

39--TODO: Don't hardcode this

@@ -146,7 +145,7 @@ findProjectRoot target = do

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

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

147 return result

146 return result

148

147

149−withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m ()) -> m ()

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

150withProjectRoot target f = findProjectRoot target >>= \case

149withProjectRoot target f = findProjectRoot target >>= \case

151 Nothing -> failWith "Must be used inside of an Obelisk project"

150 Nothing -> failWith "Must be used inside of an Obelisk project"

152 Just root -> f root

151 Just root -> f root

@@ -204,7 +203,7 @@ inImpureProjectShell shellName command = withProjectRoot "." $ \root ->

204 projectShell root False shellName command

203 projectShell root False shellName command

205

204

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

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

207−projectShell root isPure shellName command = withNixRemoteCheck $ do

206+projectShell root isPure shellName command = do

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

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

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

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

210 [ "-A"

209 [ "-A"

lib/command/src/Obelisk/Command/Run.hs+20−5

@@ -26,16 +26,19 @@ import Hpack.Config

26import Hpack.Render

27import Hpack.Yaml

28import Language.Haskell.Extension

29−import Network.Socket

29+import Network.Socket hiding (Debug)

30import System.Directory

31import System.FilePath

32+import System.Process (proc)

32import System.IO.Temp (withSystemTempDirectory)

33import System.IO.Temp (withSystemTempDirectory)

33import Data.ByteString (ByteString)

34import Data.ByteString (ByteString)

35import Obelisk.App (MonadObelisk, ObeliskT)

36import Obelisk.App (MonadObelisk, ObeliskT)

37+import Obelisk.CliApp

38+ ( CliT (..), HasCliConfig, Severity (..)

36−import Obelisk.CliApp (CliT (..), HasCliConfig, Severity (..), callCommand, failWith, getCliConfig, putLog,

39+ , callCommand, failWith, getCliConfig, putLog

37− runCli)

40+ , readProcessAndLogStderr, runCli)

38−import Obelisk.Command.Project (inProjectShell)

41+import Obelisk.Command.Project (inProjectShell, withProjectRoot)

40data CabalPackageInfo = CabalPackageInfo

43data CabalPackageInfo = CabalPackageInfo

41 { _cabalPackageInfo_packageRoot :: FilePath

44 { _cabalPackageInfo_packageRoot :: FilePath

@@ -51,7 +54,19 @@ run = do

51 pkgs <- getLocalPkgs

54 pkgs <- getLocalPkgs

52 withGhciScript pkgs $ \dotGhciPath -> do

55 withGhciScript pkgs $ \dotGhciPath -> do

53 freePort <- getFreePort

56 freePort <- getFreePort

54− runGhcid dotGhciPath $ Just $ unwords ["run", show freePort, "(runServeAsset Obelisk.Generated.Static.staticRootPath)", "Backend.backend", "Frontend.frontend"]

57+ assets <- withProjectRoot "." $ \root ->

58+ -- `--raw` is not available with old nix-instantiate. It drops quotation

59+ -- marks and trailing newline, so is very convenient for shelling out.

60+ readProcessAndLogStderr Debug $

61+ proc "nix" ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]

62+ putLog Debug $ "Assets impurely loaded from: " <> assets

63+ runGhcid dotGhciPath $ Just $ unwords

64+ [ "run"

65+ , show freePort

66+ , "(runServeAsset " ++ show assets ++ ")"

67+ , "Backend.backend"

68+ , "Frontend.frontend"

69+ ]

56runRepl :: MonadObelisk m => m ()

71runRepl :: MonadObelisk m => m ()

57runRepl = do

72runRepl = do

lib/command/src/Obelisk/Command/Thunk.hs+31−23

@@ -33,6 +33,7 @@ module Obelisk.Command.Thunk

34import Control.Applicative

35import Control.Exception (displayException, try)

36+import qualified Control.Lens as Lens

36import Control.Lens.Indexed hiding ((<.>))

37import Control.Lens.Indexed hiding ((<.>))

37import Control.Monad

38import Control.Monad

38import Control.Monad.Catch (handle)

39import Control.Monad.Catch (handle)

@@ -73,7 +74,6 @@ import Text.URI

74import Obelisk.App (MonadObelisk)

75import Obelisk.App (MonadObelisk)

75import Obelisk.CliApp

76import Obelisk.CliApp

76−import Obelisk.Command.Nix (withNixRemoteCheck)

77import Obelisk.Command.Utils

79--TODO: Support symlinked thunk data

@@ -160,14 +160,14 @@ getNixSha256ForUriUnpacked

160 -> m NixSha256

161getNixSha256ForUriUnpacked uri =

162 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do

163− [hash] <- fmap T.lines $ withNixRemoteCheck $ readProcessAndLogOutput (Debug, Debug) $

163+ [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $

164 proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]

165 pure hash

166

167nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256

168nixPrefetchGit uri rev fetchSubmodules =

169 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do

170− out <- withNixRemoteCheck $ readProcessAndLogStderr Debug $

170+ out <- readProcessAndLogStderr Debug $

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

172 [ "--url", T.unpack $ render uri

173 , "--rev", T.unpack rev

@@ -502,13 +502,13 @@ nixBuildThunkAttrWithCache thunkDir attr = do

502 Just c -> return c

503 Nothing -> do

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

505− _ <- nixBuild $ def

505+ _ <- nixCmd $ NixCmd_Build$ def

506− { _nixBuildConfig_target = Target

506+ Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

507+ Lens.& nixCmdConfig_target Lens..~ Target

507− { _target_path = thunkDir

508+ { _target_path = Just thunkDir

508 , _target_attr = Just attr

509 , _target_attr = Just attr

510+ , _target_expr = Nothing

509 }

511 }

510− , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath

511− }

512 return cachePath

513

514-- | Build a nix attribute, and cache the result if possible

@@ -524,13 +524,13 @@ nixBuildAttrWithCache exprPath attr = do

524 readThunk exprPath >>= \case

525 -- Only packed thunks are cached. in particular, checkouts are not

526 Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr

527− _ -> nixBuild $ def

527+ _ -> nixCmd $ NixCmd_Build $ def

528− { _nixBuildConfig_target = Target

528+ Lens.& nixBuildConfig_outLink Lens..~ OutLink_None

529+ Lens.& nixCmdConfig_target Lens..~ Target

529− { _target_path = exprPath

530+ { _target_path = Just exprPath

530 , _target_attr = Just attr

531 , _target_attr = Just attr

532+ , _target_expr = Nothing

531 }

533 }

532− , _nixBuildConfig_outLink = OutLink_None

533− }

534

535-- | Safely update thunk using a custom action

536--

@@ -554,7 +554,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

554 return tmpThunk

555 Right _ -> failWith $ "Thunk is not packed"

556 updateThunkFromTmp p' = do

557− packThunk' True p'

557+ _ <- packThunk' True p'

558 callProcessAndLogOutput (Notice, Error) $

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

560

@@ -564,8 +564,16 @@ finalMsg noTrail s = if noTrail then Nothing else Just s

564unpackThunk :: MonadObelisk m => FilePath -> m ()

565unpackThunk = unpackThunk' False

566

567+-- | Check that we are not somewhere inside the thunk directory

568+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()

569+checkThunkDirectory thunkDir = do

570+ currentDir <- liftIO getCurrentDirectory

571+ thunkDir' <- liftIO $ canonicalizePath thunkDir

572+ when (thunkDir' `L.isInfixOf` currentDir) $

573+ failWith "Can't pack/unpack from within the thunk directory"

574+

567unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()

575unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()

568−unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case

576+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir >> readThunk thunkDir >>= \case

569 Left err -> failWith $ "thunk unpack: " <> T.pack (show err)

577 Left err -> failWith $ "thunk unpack: " <> T.pack (show err)

570 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty

578 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty

571 Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"

579 Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"

@@ -582,12 +590,11 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case

582 git $ [ "clone" ]

590 git $ [ "clone" ]

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

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

584 ++ [ T.unpack $ render $ _gitSource_url s ]

592 ++ [ T.unpack $ render $ _gitSource_url s ]

593+ ++ do branch <- maybeToList $ _gitSource_branch s

594+ [ "--branch", T.unpack $ untagName branch ]

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

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

586 when (_gitSource_fetchSubmodules s) $

596 when (_gitSource_fetchSubmodules s) $

587 git ["submodule", "update", "--recursive", "--init"]

597 git ["submodule", "update", "--recursive", "--init"]

588− case _gitSource_branch s of

589− Just b -> git ["branch", "-u", "origin/" <> T.unpack (untagName $ b)]

590− Nothing -> pure ()

591

598

592 liftIO $ createDirectory obGitDir

599 liftIO $ createDirectory obGitDir

593 callProcessAndLogOutput (Notice, Error) $

600 callProcessAndLogOutput (Notice, Error) $

@@ -599,11 +606,11 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case

599

606

600--TODO: add force mode to pack even if changes are present

607--TODO: add force mode to pack even if changes are present

601--TODO: add a rollback mode to pack to the original thunk

608--TODO: add a rollback mode to pack to the original thunk

602−packThunk :: MonadObelisk m => FilePath -> m ()

609+packThunk :: MonadObelisk m => FilePath -> m ThunkPtr

603packThunk = packThunk' False

610packThunk = packThunk' False

604

611

605−packThunk' :: MonadObelisk m => Bool -> FilePath -> m ()

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

606−packThunk' noTrail thunkDir = readThunk thunkDir >>= \case

613+packThunk' noTrail thunkDir = checkThunkDirectory thunkDir >> readThunk thunkDir >>= \case

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

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

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

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

609 Right (ThunkData_Checkout _) -> do

616 Right (ThunkData_Checkout _) -> do

@@ -612,6 +619,7 @@ packThunk' noTrail thunkDir = readThunk thunkDir >>= \case

612 thunkPtr <- getThunkPtr thunkDir

619 thunkPtr <- getThunkPtr thunkDir

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

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

614 liftIO $ createThunk thunkDir thunkPtr

621 liftIO $ createThunk thunkDir thunkPtr

622+ pure thunkPtr

615

623

616getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr

624getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr

617getThunkPtr = getThunkPtr' True

625getThunkPtr = getThunkPtr' True

@@ -663,7 +671,7 @@ getThunkPtr' checkClean thunkDir = do

663 let untrackedBranches = Map.keys errorMap

671 let untrackedBranches = Map.keys errorMap

664 when (not $ L.null untrackedBranches) $ failWith $ T.unlines $

672 when (not $ L.null untrackedBranches) $ failWith $ T.unlines $

665 [ "thunk pack: Certain branches in the thunk have no upstream branch \

673 [ "thunk pack: Certain branches in the thunk have no upstream branch \

666− \set. This means don't know to check whether all your work is \

674+ \set. This means we don't know to check whether all your work is \

667 \saved. The offending branches are:"

675 \saved. The offending branches are:"

668 , ""

676 , ""

669 , T.unwords untrackedBranches

677 , T.unwords untrackedBranches

@@ -752,7 +760,7 @@ uriThunkPtr uri mbranch = do

752 Left e -> do

760 Left e -> do

753 putLog Warning $ "\

761 putLog Warning $ "\

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

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

755−\Falling back on normal fetchgit. Original failure:\n\n"

763+\Falling back on normal fetchgit. Original failure:"

756 errorToWarning e

764 errorToWarning e

757 let s' = forgetGithub True s

765 let s' = forgetGithub True s

758 (,) (ThunkSource_Git s') <$> gitThunkRev s' commit

766 (,) (ThunkSource_Git s') <$> gitThunkRev s' commit

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

@@ -23,7 +23,6 @@ import System.Process (cwd, proc)

24import Obelisk.App (MonadObelisk)

25import Obelisk.CliApp

26−import Obelisk.Command.Nix (withNixRemoteCheck)

27import Obelisk.Command.Utils

26import Obelisk.Command.Utils

29import Obelisk.Migration

28import Obelisk.Migration

@@ -88,7 +87,7 @@ getHashAtGitRevision revs excludes dir = withSystemTempDirectory "obelisk-hashre

88 return result

87 return result

90nixHash :: MonadObelisk m => FilePath -> m Hash

89nixHash :: MonadObelisk m => FilePath -> m Hash

91−nixHash dir = withSpinnerNoTrail "Running `nix-hash`" $ withNixRemoteCheck $

90+nixHash dir = withSpinnerNoTrail "Running `nix-hash`" $

92 readProc $ proc "nix-hash" [dir]

91 readProc $ proc "nix-hash" [dir]

94-- | Clean up the following files in the git working copy

93-- | Clean up the following files in the git working copy

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

@@ -22,7 +22,6 @@ import System.Process (proc)

23import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

24import Obelisk.CliApp

25−import Obelisk.Command.Nix (withNixRemoteCheck)

27-- | Generate the `--builders` argument string to enable the VM builder after ensuring it is available.

26-- | Generate the `--builders` argument string to enable the VM builder after ensuring it is available.

28getNixBuildersArg :: MonadObelisk m => m String

27getNixBuildersArg :: MonadObelisk m => m String

@@ -155,7 +154,7 @@ getDockerBuilderStateDir = liftA2 (</>) getObeliskUserStateDir (pure "nix-docker

155testLinuxBuild :: MonadObelisk m => FilePath -> m ()

154testLinuxBuild :: MonadObelisk m => FilePath -> m ()

156testLinuxBuild stateDir

155testLinuxBuild stateDir

157 | System.Info.os == "linux" = failWith "Using the docker builder is not necessary on linux."

156 | System.Info.os == "linux" = failWith "Using the docker builder is not necessary on linux."

158− | otherwise = withNixRemoteCheck $ do

157+ | otherwise = do

159 (exitCode, _stdout, stderr) <- readCreateProcessWithExitCode $ proc "nix-build"

158 (exitCode, _stdout, stderr) <- readCreateProcessWithExitCode $ proc "nix-build"

160 [ "-E", "(import <nixpkgs> { system = \"x86_64-linux\"; }).writeText \"test\" builtins.currentTime"

159 [ "-E", "(import <nixpkgs> { system = \"x86_64-linux\"; }).writeText \"test\" builtins.currentTime"

161 , "--builders", nixBuildersArgString stateDir

160 , "--builders", nixBuildersArgString stateDir

lib/frontend/src/Obelisk/Frontend.hs+14−10

@@ -31,6 +31,8 @@ import Data.ByteString (ByteString)

31import Data.Dependent.Sum (DSum (..))

32import Data.Functor.Sum

33import Data.IORef

34+import Data.Monoid ((<>))

35+import Data.Text (Text)

34import GHCJS.DOM hiding (bracket, catch)

36import GHCJS.DOM hiding (bracket, catch)

35import GHCJS.DOM.Document

37import GHCJS.DOM.Document

36import GHCJS.DOM.Node

38import GHCJS.DOM.Node

@@ -63,6 +65,7 @@ type ObeliskWidget t x route m =

63 , PrimMonad m

65 , PrimMonad m

64 , Prerender x m

66 , Prerender x m

65 , SetRoute t route m

67 , SetRoute t route m

68+ , RouteToUrl route m

66 )

69 )

68data Frontend route = Frontend

71data Frontend route = Frontend

@@ -80,7 +83,7 @@ type DomCoreWidget x = PostBuildT DomTimeline (WithJSContextSingleton x (Perform

80--TODO: Rename

83--TODO: Rename

81{-# INLINABLE attachWidget''' #-}

84{-# INLINABLE attachWidget''' #-}

82attachWidget'''

85attachWidget'''

83− :: (EventChannel -> PerformEventT DomTimeline (SpiderHost Global) (IORef (Maybe (EventTrigger DomTimeline ()))))

86+ :: (EventChannel -> PerformEventT DomTimeline DomHost (IORef (Maybe (EventTrigger DomTimeline ()))))

84 -> IO ()

87 -> IO ()

85attachWidget''' w = runDomHost $ do

88attachWidget''' w = runDomHost $ do

86 events <- liftIO newChan

89 events <- liftIO newChan

@@ -142,22 +145,23 @@ runFrontend validFullEncoder frontend = do

142 , MonadFix m

145 , MonadFix m

143 , MonadFix (Performable m)

146 , MonadFix (Performable m)

144 )

147 )

145− => RoutedT t (R route) (SetRouteT t (R route) m) a

148+ => RoutedT t (R route) (SetRouteT t (R route) (RouteToUrlT (R route) m)) a

146 -> m a

149 -> m a

147 runMyRouteViewT = runRouteViewT ve

150 runMyRouteViewT = runRouteViewT ve

148 runWithHeadAndBody $ \appendHead appendBody -> runMyRouteViewT $ do

151 runWithHeadAndBody $ \appendHead appendBody -> runMyRouteViewT $ do

149− mapRoutedT (mapSetRouteT appendHead) $ _frontend_head frontend

152+ mapRoutedT (mapSetRouteT (mapRouteToUrlT appendHead)) $ _frontend_head frontend

150− mapRoutedT (mapSetRouteT appendBody) $ _frontend_body frontend

153+ mapRoutedT (mapSetRouteT (mapRouteToUrlT appendBody)) $ _frontend_body frontend

151

154

152renderFrontendHtml

155renderFrontendHtml

153− :: (t ~ SpiderTimeline Global)

156+ :: (t ~ DomTimeline)

157+ => (r' -> Text)

154− => r

158+ -> r

155− -> RoutedT t r (SetRouteT t r' (PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global))))) ()

159+ -> RoutedT t r (SetRouteT t r' (RouteToUrlT r' (PostBuildT DomTimeline (StaticDomBuilderT DomTimeline (PerformEventT DomTimeline DomHost))))) ()

156− -> RoutedT t r (SetRouteT t r' (PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global))))) ()

160+ -> RoutedT t r (SetRouteT t r' (RouteToUrlT r' (PostBuildT DomTimeline (StaticDomBuilderT DomTimeline (PerformEventT DomTimeline DomHost))))) ()

157 -> IO ByteString

161 -> IO ByteString

158−renderFrontendHtml route headWidget bodyWidget = do

162+renderFrontendHtml urlEnc route headWidget bodyWidget = do

159 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline

163 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline

160− html <- fmap snd $ renderStatic $ fmap fst $ runSetRouteT $ flip runRoutedT (pure route) $

164+ html <- fmap snd $ renderStatic $ fmap fst $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $

161 el "html" $ do

165 el "html" $ do

162 el "head" headWidget

166 el "head" headWidget

163 el "body" bodyWidget

167 el "body" bodyWidget

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

@@ -103,6 +103,7 @@ import Data.List.NonEmpty (NonEmpty (..))

103import Data.Map (Map)

104import qualified Data.Map as Map

105import Data.Maybe

106+import Data.Monoid ((<>))

106import Data.Set (Set)

107import Data.Set (Set)

107import qualified Data.Set as Set

108import qualified Data.Set as Set

108import Data.Some (Some)

109import Data.Some (Some)

@@ -528,6 +529,12 @@ unitEncoder expected = unsafeMkEncoder $ EncoderImpl

528singlePathSegmentEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse Text PageName

529singlePathSegmentEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse Text PageName

529singlePathSegmentEncoder = pathOnlyEncoder . singletonListEncoder

530singlePathSegmentEncoder = pathOnlyEncoder . singletonListEncoder

530

531

532+pathOnlyEncoderIgnoringQuery :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName

533+pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl

534+ { _encoderImpl_decode = \(path, _query) -> pure path

535+ , _encoderImpl_encode = \path -> (path, mempty)

536+ }

537+

531pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName

538pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName

532pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl

539pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl

533 { _encoderImpl_decode = \(path, query) ->

540 { _encoderImpl_decode = \(path, query) ->

@@ -714,6 +721,7 @@ data ResourceRoute :: * -> * where

714 ResourceRoute_Static :: ResourceRoute [Text] -- This [Text] represents the *path in our static files directory*, not necessarily the URL path that the asset gets served at (although that will often be "/static/this/text/thing")

721 ResourceRoute_Static :: ResourceRoute [Text] -- This [Text] represents the *path in our static files directory*, not necessarily the URL path that the asset gets served at (although that will often be "/static/this/text/thing")

715 ResourceRoute_Ghcjs :: ResourceRoute [Text]

722 ResourceRoute_Ghcjs :: ResourceRoute [Text]

716 ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)

723 ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)

724+ ResourceRoute_Version :: ResourceRoute ()

717

725

718-- | If there are no additional backend routes in your app (i.e. ObeliskRoute gives you all the routes you need),

726-- | If there are no additional backend routes in your app (i.e. ObeliskRoute gives you all the routes you need),

719-- this constructs a suitable 'Encoder' to use for encoding routes to 'PageName's. If you do have additional backend routes,

727-- this constructs a suitable 'Encoder' to use for encoding routes to 'PageName's. If you do have additional backend routes,

@@ -747,9 +755,10 @@ obeliskRouteSegment r appRouteSegment = case r of

747-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.

755-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.

748resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a

756resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a

749resourceRouteSegment = \case

757resourceRouteSegment = \case

750− ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoder

758+ ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoderIgnoringQuery

751 ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder

759 ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder

752 ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder

760 ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder

761+ ResourceRoute_Version -> PathSegment "version" $ unitEncoder mempty

753

762

754data JSaddleWarpRoute :: * -> * where

763data JSaddleWarpRoute :: * -> * where

755 JSaddleWarpRoute_JavaScript :: JSaddleWarpRoute ()

764 JSaddleWarpRoute_JavaScript :: JSaddleWarpRoute ()

lib/route/src/Obelisk/Route/Frontend.hs+126−5

@@ -41,6 +41,11 @@ module Obelisk.Route.Frontend

41 , SetRoute(..)

42 , runSetRouteT

43 , mapSetRouteT

44+ , RouteToUrl(..)

45+ , RouteToUrlT(..)

46+ , runRouteToUrlT

47+ , mapRouteToUrlT

48+ , routeLink

44 ) where

49 ) where

46import Prelude hiding ((.), id)

51import Prelude hiding ((.), id)

@@ -49,7 +54,7 @@ import Obelisk.Route

50import Control.Category (Category (..), (.))

55import Control.Category (Category (..), (.))

51import Control.Category.Cartesian

56import Control.Category.Cartesian

52−import Control.Lens hiding (Bifunctor, bimap, universe)

57+import Control.Lens hiding (Bifunctor, bimap, universe, element)

53import Control.Monad.Fix

58import Control.Monad.Fix

54import Control.Monad.Primitive

59import Control.Monad.Primitive

55import Control.Monad.Ref

60import Control.Monad.Ref

@@ -61,6 +66,8 @@ import Data.Constraint (Dict (..))

61import Data.Dependent.Sum (DSum (..))

66import Data.Dependent.Sum (DSum (..))

62import Data.GADT.Compare

67import Data.GADT.Compare

63import Data.Monoid

68import Data.Monoid

69+import Data.Proxy

70+import Data.Text (Text)

64import qualified Data.Text as T

71import qualified Data.Text as T

65import Data.Functor.Compose

72import Data.Functor.Compose

66import Reflex.Class

73import Reflex.Class

@@ -95,7 +102,11 @@ instance Monad m => Routed t r (RoutedT t r m) where

95 askRoute = RoutedT ask

102 askRoute = RoutedT ask

103

97newtype RoutedT t r m a = RoutedT { unRoutedT :: ReaderT (Dynamic t r) m a }

104newtype RoutedT t r m a = RoutedT { unRoutedT :: ReaderT (Dynamic t r) m a }

98− deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, HasJSContext, MonadIO, MonadReflexCreateTrigger t, HasDocument)

105+ deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument)

106+

107+instance HasJSContext m => HasJSContext (RoutedT t r m) where

108+ type JSContextPhantom (RoutedT t r m) = JSContextPhantom m

109+ askJSContext = lift askJSContext

110

100instance Prerender js m => Prerender js (RoutedT t r m) where

111instance Prerender js m => Prerender js (RoutedT t r m) where

101 prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

112 prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

@@ -213,7 +224,18 @@ strictDynWidget_ f = RoutedT $ ReaderT $ \r -> do

213 pure ()

224 pure ()

214

225

215newtype SetRouteT t r m a = SetRouteT { unSetRouteT :: EventWriterT t (Endo r) m a }

226newtype SetRouteT t r m a = SetRouteT { unSetRouteT :: EventWriterT t (Endo r) m a }

216− deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, HasJSContext, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomBuilder t)

227+ deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, MonadIO, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadReflexCreateTrigger t, HasDocument)

228+

229+instance (MonadFix m, MonadHold t m, DomBuilder t m) => DomBuilder t (SetRouteT t r m) where

230+ type DomBuilderSpace (SetRouteT t r m) = DomBuilderSpace m

231+ element t cfg child = SetRouteT $ element t cfg $ unSetRouteT child

232+ inputElement = lift . inputElement

233+ textAreaElement = lift . textAreaElement

234+ selectElement cfg child = SetRouteT $ selectElement cfg $ unSetRouteT child

235+

236+instance HasJSContext m => HasJSContext (SetRouteT t r m) where

237+ type JSContextPhantom (SetRouteT t r m) = JSContextPhantom m

238+ askJSContext = lift askJSContext

217

239

218mapSetRouteT :: (forall x. m x -> n x) -> SetRouteT t r m a -> SetRouteT t r n a

240mapSetRouteT :: (forall x. m x -> n x) -> SetRouteT t r m a -> SetRouteT t r n a

219mapSetRouteT f (SetRouteT x) = SetRouteT (mapEventWriterT f x)

241mapSetRouteT f (SetRouteT x) = SetRouteT (mapEventWriterT f x)

@@ -275,6 +297,85 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where

275 askQueryResult = lift askQueryResult

297 askQueryResult = lift askQueryResult

276 queryIncremental = lift . queryIncremental

298 queryIncremental = lift . queryIncremental

277

299

300+class RouteToUrl r m | m -> r where

301+ askRouteToUrl :: m (r -> Text)

302+

303+newtype RouteToUrlT r m a = RouteToUrlT { unRouteToUrlT :: ReaderT (r -> Text) m a }

304+ deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument)

305+

306+runRouteToUrlT

307+ :: RouteToUrlT r m a

308+ -> (r -> Text)

309+ -> m a

310+runRouteToUrlT a = runReaderT (unRouteToUrlT a)

311+

312+mapRouteToUrlT :: (forall x. m x -> n x) -> RouteToUrlT r m a -> RouteToUrlT r n a

313+mapRouteToUrlT f (RouteToUrlT m) = RouteToUrlT $ mapReaderT f m

314+

315+instance Monad m => RouteToUrl r (RouteToUrlT r m) where

316+ askRouteToUrl = RouteToUrlT ask

317+

318+instance (Monad m, RouteToUrl r m) => RouteToUrl r (SetRouteT t r' m) where

319+ askRouteToUrl = lift askRouteToUrl

320+

321+instance (Monad m, RouteToUrl r m) => RouteToUrl r (RoutedT t r' m) where

322+ askRouteToUrl = lift askRouteToUrl

323+

324+instance HasJSContext m => HasJSContext (RouteToUrlT r m) where

325+ type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m

326+ askJSContext = lift askJSContext

327+

328+instance Prerender js m => Prerender js (RouteToUrlT r m) where

329+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))

330+

331+instance Requester t m => Requester t (RouteToUrlT r m) where

332+ type Request (RouteToUrlT r m) = Request m

333+ type Response (RouteToUrlT r m) = Response m

334+ requesting = RouteToUrlT . requesting

335+ requesting_ = RouteToUrlT . requesting_

336+

337+#ifndef ghcjs_HOST_OS

338+deriving instance MonadJSM m => MonadJSM (RouteToUrlT r m)

339+#endif

340+

341+instance PerformEvent t m => PerformEvent t (RouteToUrlT r m) where

342+ type Performable (RouteToUrlT r m) = Performable m

343+ performEvent = lift . performEvent

344+ performEvent_ = lift . performEvent_

345+

346+instance MonadRef m => MonadRef (RouteToUrlT r m) where

347+ type Ref (RouteToUrlT r m) = Ref m

348+ newRef = lift . newRef

349+ readRef = lift . readRef

350+ writeRef r = lift . writeRef r

351+

352+instance HasJS x m => HasJS x (RouteToUrlT r m) where

353+ type JSX (RouteToUrlT r m) = JSX m

354+ liftJS = lift . liftJS

355+

356+instance MonadTransControl (RouteToUrlT r) where

357+ type StT (RouteToUrlT r) a = StT (ReaderT (r -> Text)) a

358+ liftWith = defaultLiftWith RouteToUrlT unRouteToUrlT

359+ restoreT = defaultRestoreT RouteToUrlT

360+

361+instance PrimMonad m => PrimMonad (RouteToUrlT r m ) where

362+ type PrimState (RouteToUrlT r m) = PrimState m

363+ primitive = lift . primitive

364+

365+instance DomBuilder t m => DomBuilder t (RouteToUrlT r m) where

366+ type DomBuilderSpace (RouteToUrlT r m) = DomBuilderSpace m

367+

368+instance Adjustable t m => Adjustable t (RouteToUrlT r m) where

369+ runWithReplace a0 a' = RouteToUrlT $ runWithReplace (coerce a0) $ coerceEvent a'

370+ traverseIntMapWithKeyWithAdjust f a0 a' = RouteToUrlT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'

371+ traverseDMapWithKeyWithAdjust f a0 a' = RouteToUrlT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'

372+ traverseDMapWithKeyWithAdjustWithMove f a0 a' = RouteToUrlT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) (coerce a0) $ coerce a'

373+

374+instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where

375+ tellQueryIncremental = lift . tellQueryIncremental

376+ askQueryResult = lift askQueryResult

377+ queryIncremental = lift . queryIncremental

378+

278runRouteViewT

379runRouteViewT

279 :: forall t m r a.

380 :: forall t m r a.

280 ( TriggerEvent t m

381 ( TriggerEvent t m

@@ -285,7 +386,7 @@ runRouteViewT

285 , MonadFix m

386 , MonadFix m

286 )

387 )

287 => (Encoder Identity Identity r PageName)

388 => (Encoder Identity Identity r PageName)

288− -> RoutedT t r (SetRouteT t r m) a

389+ -> RoutedT t r (SetRouteT t r (RouteToUrlT r m)) a

289 -> m a

390 -> m a

290runRouteViewT routeEncoder a = do

391runRouteViewT routeEncoder a = do

291 rec historyState <- manageHistory $ HistoryCommand_PushState <$> setState

392 rec historyState <- manageHistory $ HistoryCommand_PushState <$> setState

@@ -298,7 +399,7 @@ runRouteViewT routeEncoder a = do

298 where

399 where

299 errorLeft (Left e) = error (T.unpack e)

400 errorLeft (Left e) = error (T.unpack e)

300 errorLeft (Right x) = x

401 errorLeft (Right x) = x

301− (result, changeState) <- runSetRouteT $ runRoutedT a route

402+ (result, changeState) <- runRouteToUrlT (runSetRouteT $ runRoutedT a route) $ (\(p, q) -> T.pack $ p <> q) . encode theEncoder

302 let f (currentHistoryState, oldRoute) change =

403 let f (currentHistoryState, oldRoute) change =

303 let newRoute = appEndo change oldRoute

404 let newRoute = appEndo change oldRoute

304 (newPath, newQuery) = encode theEncoder newRoute

405 (newPath, newQuery) = encode theEncoder newRoute

@@ -322,6 +423,26 @@ runRouteViewT routeEncoder a = do

322 setState = attachWith f ((,) <$> current historyState <*> current route) changeState

423 setState = attachWith f ((,) <$> current historyState <*> current route) changeState

323 return result

424 return result

324

425

426+-- | A link widget that, when clicked, sets the route to the provided route. In non-javascript

427+-- contexts, this widget falls back to using @href@s to control navigation

428+routeLink

429+ :: forall t m a route.

430+ ( DomBuilder t m

431+ , RouteToUrl (R route) m

432+ , SetRoute t (R route) m

433+ )

434+ => R route -- ^ Target route

435+ -> m a -- ^ Child widget

436+ -> m a

437+routeLink r w = do

438+ enc <- askRouteToUrl

439+ let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

440+ & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

441+ & elementConfig_initialAttributes .~ "href" =: enc r

442+ (e, a) <- element "a" cfg w

443+ setRoute $ r <$ domEvent Click e

444+ return a

445+

325-- On ios due to sandboxing when loading the page from a file adapt the

446-- On ios due to sandboxing when loading the page from a file adapt the

326-- path to be based on the hash.

447-- path to be based on the hash.

327

448

lib/run/src/Obelisk/Run.hs+8−6

@@ -82,7 +82,8 @@ run port serveStaticAsset backend frontend = do

82 getRouteWith validFullEncoder >>= \case

83 Identity r -> case r of

84 InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

85+ InR obeliskRoute :=> Identity a ->

85− InR obeliskRoute :=> Identity a -> serveDefaultObeliskApp serveStaticAsset frontend $ obeliskRoute :/ a

86+ serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend $ obeliskRoute :/ a

86 let conf = defRunConfig { _runConfig_redirectPort = port }

87 let conf = defRunConfig { _runConfig_redirectPort = port }

87 runWidget conf frontend validFullEncoder `finally` killThread backendTid

88 runWidget conf frontend validFullEncoder `finally` killThread backendTid

@@ -142,14 +143,15 @@ obeliskApp opts frontend validFullEncoder uri backend = do

142 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

143 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

143 }

144 }

144 InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do

145 InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do

145− html <- renderJsaddleFrontend (appRouteComponent :/ appRouteRest) frontend

146+ html <- renderJsaddleFrontend (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend

146− sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] $ BSLC.fromStrict html

147+ sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html

147 _ -> backend req sendResponse

148 _ -> backend req sendResponse

148

149

149−renderJsaddleFrontend :: route -> Frontend route -> IO ByteString

150+renderJsaddleFrontend :: (route -> Text) -> route -> Frontend route -> IO ByteString

150−renderJsaddleFrontend r f =

151+renderJsaddleFrontend urlEnc r f =

151 let jsaddleScript = elAttr "script" ("src" =: "/jsaddle/jsaddle.js") blank

152 let jsaddleScript = elAttr "script" ("src" =: "/jsaddle/jsaddle.js") blank

153+ jsaddlePreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "/jsaddle/jsaddle.js") blank

152− in renderFrontendHtml r (_frontend_head f >> injectExecutableConfigs) (_frontend_body f >> jsaddleScript)

154+ in renderFrontendHtml urlEnc r (_frontend_head f >> injectExecutableConfigs >> jsaddlePreload) (_frontend_body f >> jsaddleScript)

153

155

154-- | like 'bindPortTCP' but reconnects on exception

156-- | like 'bindPortTCP' but reconnects on exception

155bindPortTCPRetry :: Settings

157bindPortTCPRetry :: Settings

lib/selftest/src/Obelisk/SelfTest.hs+63−64

@@ -64,22 +64,8 @@ tshow :: Show a => a -> Text

64tshow = T.pack . show

66-- | Like `shelly` but used when running `ob` commands

67−--

68−-- This tests the NIX_REMOTE workaround, whether that gets printed

69−-- on failure, and whether retrying with the suggested workaround

70−-- leads to the test succeeding.

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

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

72−shellyOb f obTest = shelly $ f $ do

68+shellyOb f obTest = shelly $ f obTest

73− obTest `catch_sh` \(e :: RunFailed) -> do

74− obStderr <- lastStderr

75− if T.isInfixOf "export NIX_REMOTE" obStderr

76− then do

77− runCli $ do

78− putLog Notice "Detected NIX_REMOTE suggestion in stderr of failed ob"

79− putLog Warning "Retrying this test with NIX_REMOTE=daemon"

80− setenv "NIX_REMOTE" "daemon"

81− f obTest

82− else throw e

84main :: IO ()

70main :: IO ()

85main = do

71main = do

@@ -90,15 +76,23 @@ main = do

90 let verbosity = bool silently verbosely isVerbose

76 let verbosity = bool silently verbosely isVerbose

91 obeliskImpl <- fromString <$> getEnv "OBELISK_IMPL"

77 obeliskImpl <- fromString <$> getEnv "OBELISK_IMPL"

92 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

78 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

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

93− withSystemTempDirectory "blank-project" $ \blankProject ->

80+ withSystemTempDirectory "initCache" $ \initCache -> do

81+ -- Setup the ob init cache

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

83+ run_ "ob" ["init"]

84+ run_ "git" ["init"]

94− hspec $ do

85+ hspec $ parallel $ do

95 let shelly_ = void . shellyOb verbosity

86 let shelly_ = void . shellyOb verbosity

97− inProj :: Sh a -> IO ()

98− inProj = shelly_ . chdir (fromString blankProject)

99−

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

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

101− inTmp f = shelly_ . withSystemTempDirectory "ob-init" $ (chdir <*> f) . fromString

89+ inTmp f = withTmp (chdir <*> f)

90+

91+ withTmp f = shelly_ . withSystemTempDirectory "test" $ f . fromString

92+

93+ inTmpObInit f = inTmp $ \dir -> do

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

95+ f dir

102

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

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

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

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

@@ -117,7 +111,7 @@ main = do

117

111

118 diff a b = run "git" ["diff", a, b]

112 diff a b = run "git" ["diff", a, b]

119

113

120− describe "ob init" $ do

114+ describe "ob init" $ parallel $ do

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

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

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

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

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

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

@@ -132,57 +126,53 @@ main = do

132 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

126 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

133 ls tmp >>= liftIO . assertEqual "" []

127 ls tmp >>= liftIO . assertEqual "" []

134

128

135− it "produces a valid route config" $ inTmp $ \tmp -> do

129+ it "produces a valid route config" $ inTmpObInit $ \tmp -> do

136− run_ "ob" ["init"]

137 liftIO $ withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ getConfigRoute `shouldNotReturn` Nothing

130 liftIO $ withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ getConfigRoute `shouldNotReturn` Nothing

138

131

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

133+ -- when not run by 'nix-build --attr selftest'

139− describe "ob run" $ do

134+ describe "ob run" $ parallel $ do

140− it "works in root directory" $ inTmp $ \_ -> do

135+ it "works in root directory" $ inTmpObInit $ \_ -> do

141− run_ "ob" ["init"]

142− testObRunInDir Nothing httpManager

136+ testObRunInDir p0 p1 Nothing httpManager

143− it "works in sub directory" $ inTmp $ \_ -> do

137+ it "works in sub directory" $ inTmpObInit $ \_ -> do

144− run_ "ob" ["init"]

145− testObRunInDir (Just "frontend") httpManager

138+ testObRunInDir p2 p3 (Just "frontend") httpManager

146

139

147 describe "obelisk project" $ parallel $ do

140 describe "obelisk project" $ parallel $ do

148− it "can build obelisk command" $ shelly_ $ run "nix-build" ["-A", "command" , obeliskImpl]

141+ it "can build obelisk command" $ inTmpObInit $ \_ -> run "nix-build" ["-A", "command" , obeliskImpl]

149− it "can build obelisk skeleton" $ shelly_ $ run "nix-build" ["-A", "skeleton", obeliskImpl]

142+ it "can build obelisk skeleton" $ inTmpObInit $ \_ -> run "nix-build" ["-A", "skeleton", obeliskImpl]

150− it "can build obelisk shell" $ shelly_ $ run "nix-build" ["-A", "shell", obeliskImpl]

143+ it "can build obelisk shell" $ inTmpObInit $ \_ -> run "nix-build" ["-A", "shell", obeliskImpl]

151 -- See https://github.com/obsidiansystems/obelisk/issues/101

144 -- See https://github.com/obsidiansystems/obelisk/issues/101

152 -- it "can build everything" $ shelly_ $ run "nix-build" [obeliskImpl]

145 -- it "can build everything" $ shelly_ $ run "nix-build" [obeliskImpl]

153

146

154− describe "blank initialized project" $ do

147+ describe "blank initialized project" $ parallel $ do

155− it "can be created" $ inProj $ do

156− run_ "ob" ["init"]

157− run_ "git" ["init"]

158− commitAll

159

148

160− it "can build ghc.backend" $ inProj $ do

149+ it "can build ghc.backend" $ inTmpObInit $ \_ -> do

161 run "nix-build" ["--no-out-link", "-A", "ghc.backend"]

150 run "nix-build" ["--no-out-link", "-A", "ghc.backend"]

162− it "can build ghcjs.frontend" $ inProj $ do

151+ it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> do

163 run "nix-build" ["--no-out-link", "-A", "ghcjs.frontend"]

152 run "nix-build" ["--no-out-link", "-A", "ghcjs.frontend"]

164

153

165 if os == "darwin"

154 if os == "darwin"

166− then it "can build ios" $ inProj $ run "nix-build" ["--no-out-link", "-A", "ios.frontend" ]

155+ then it "can build ios" $ inTmpObInit $ \_ -> run "nix-build" ["--no-out-link", "-A", "ios.frontend" ]

167− else it "can build android" $ inProj $ run "nix-build" ["--no-out-link", "-A", "android.frontend"]

156+ else it "can build android" $ inTmpObInit $ \_ -> run "nix-build" ["--no-out-link", "-A", "android.frontend"]

168

157

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

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

170 let

159 let

171 shell = "shells." <> compiler

160 shell = "shells." <> compiler

172 inShell cmd' = run "nix-shell" ["-A", fromString shell, "--run", cmd']

161 inShell cmd' = run "nix-shell" ["-A", fromString shell, "--run", cmd']

173− it ("can enter " <> shell) $ inProj $ inShell "exit"

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

174− it ("can build in " <> shell) $ inProj $ inShell $ "cabal new-build --" <> fromString compiler <> " all"

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

175

164

176− it "can build reflex project" $ inProj $ do

165+ it "can build reflex project" $ inTmpObInit $ \_ -> do

177 run "nix-build" []

166 run "nix-build" []

178

167

179− it "has idempotent thunk update" $ inProj $ do

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

180 u <- update

169 u <- update

181 uu <- update

170 uu <- update

182 assertRevEQ u uu

171 assertRevEQ u uu

183

172

184− describe "ob thunk pack/unpack" $ do

173+ describe "ob thunk pack/unpack" $ parallel $ do

185− it "has thunk pack and unpack inverses" $ inProj $ do

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

175+

186 e <- commitAll

176 e <- commitAll

187 eu <- unpack

177 eu <- unpack

188 eup <- pack

178 eup <- pack

@@ -193,6 +183,14 @@ main = do

193 assertRevEQ eu eupu

183 assertRevEQ eu eupu

194 assertRevNE e eu

184 assertRevNE e eu

195

185

186+ it "unpacks the correct branch" $ withTmp $ \dir -> do

187+ let branch = "master"

188+ run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]

189+ run_ "ob" ["thunk", "pack", toTextIgnore dir]

190+ run_ "ob" ["thunk", "unpack", toTextIgnore dir]

191+ branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]

192+ liftIO $ assertEqual "" branch (T.strip branch')

193+

196 it "can pack and unpack plain git repos" $ do

194 it "can pack and unpack plain git repos" $ do

197 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

195 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

198 let repo = toTextIgnore $ dir </> ("repo" :: String)

196 let repo = toTextIgnore $ dir </> ("repo" :: String)

@@ -211,19 +209,18 @@ main = do

211

209

212 testThunkPack $ fromText repo

210 testThunkPack $ fromText repo

213

211

214− it "aborts thunk pack when there are uncommitted files" $ inProj $ do

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

215 void $ unpack

213 void $ unpack

216− testThunkPack (blankProject </> thunk)

214+ testThunkPack (dir </> thunk)

217

215

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

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

219−testObRunInDir :: Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()

217+testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()

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

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

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

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

222− writefile "config/common/route" . uri =<< liftIO getFreePort -- Use a free port initially

220+ writefile "config/common/route" $ uri p0

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

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

224− freePort <- liftIO getFreePort

225 firstUri <- handleObRunStdout httpManager stdout

222 firstUri <- handleObRunStdout httpManager stdout

226− let newUri = uri freePort

223+ let newUri = uri p1

227 when (firstUri == newUri) $ errorExit $

224 when (firstUri == newUri) $ errorExit $

228 "Startup URI (" <> firstUri <> ") is the same as test URI (" <> newUri <> ")"

225 "Startup URI (" <> firstUri <> ") is the same as test URI (" <> newUri <> ")"

229 maybe id (\_ -> chdir "..") mdir $ alterRouteTo newUri stdout

226 maybe id (\_ -> chdir "..") mdir $ alterRouteTo newUri stdout

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

248 ensureThunkPackFails "unsaved"

245 ensureThunkPackFails "unsaved"

249 chdir path' $ commit "test commit"

246 chdir path' $ commit "test commit"

250 -- Non-pushed commits in any branch

247 -- Non-pushed commits in any branch

251− ensureThunkPackFails "not been pushed"

248+ ensureThunkPackFails "not yet pushed"

252 -- Uncommitted files (unstaged)

249 -- Uncommitted files (unstaged)

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

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

254 ensureThunkPackFails "modified"

251 ensureThunkPackFails "modified"

@@ -275,12 +272,12 @@ alterRouteTo uri stdout = do

275

272

276-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

273-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

277handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

274handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

278−handleObRunStdout httpManager stdout = flip fix ObRunState_Init $ \loop state -> do

275+handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) -> do

279 liftIO (T.hGetLine stdout) >>= \t -> case state of

276 liftIO (T.hGetLine stdout) >>= \t -> case state of

280 ObRunState_Init

277 ObRunState_Init

281− | "Running test..." `T.isPrefixOf` t -> loop ObRunState_BackendStarted

278+ | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)

282 ObRunState_Startup

279 ObRunState_Startup

283− | t == "backend stopped; make a change to your code to reload" -> loop ObRunState_Startup

280+ | t == "backend stopped; make a change to your code to reload" -> loop (ObRunState_Startup, msgs)

284 -- | Just port <- "Backend running on port " `T.stripPrefix` t -> loop $ ObRunState_BackendStarted port

281 -- | Just port <- "Backend running on port " `T.stripPrefix` t -> loop $ ObRunState_BackendStarted port

285 | not (T.null t) -> errorExit $ "Startup: " <> t -- If theres any other output here, startup failed

282 | not (T.null t) -> errorExit $ "Startup: " <> t -- If theres any other output here, startup failed

286 ObRunState_BackendStarted

283 ObRunState_BackendStarted

@@ -288,7 +285,8 @@ handleObRunStdout httpManager stdout = flip fix ObRunState_Init $ \loop state ->

288 obRunCheck httpManager stdout uri

285 obRunCheck httpManager stdout uri

289 pure uri

286 pure uri

290 | not (T.null t) -> errorExit $ "Started: " <> t -- If theres any other output here, startup failed

287 | not (T.null t) -> errorExit $ "Started: " <> t -- If theres any other output here, startup failed

288+ _ | "Failed" `T.isPrefixOf` t -> errorExit $ "ob run failed: " <> T.unlines (reverse $ t : msgs)

291− _ -> loop state

289+ | otherwise -> loop (state, t : msgs)

292

290

293-- | Make requests to frontend/backend servers to check they are working properly

291-- | Make requests to frontend/backend servers to check they are working properly

294obRunCheck :: HTTP.Manager -> Handle -> Text -> Sh ()

292obRunCheck :: HTTP.Manager -> Handle -> Text -> Sh ()

@@ -297,10 +295,11 @@ obRunCheck httpManager _stdout frontendUri = do

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

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

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

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

299

297

300−getFreePort :: IO Socket.PortNumber

298+getFreePorts :: Int -> IO [Socket.PortNumber]

299+getFreePorts 0 = pure []

301−getFreePort = Socket.withSocketsDo $ do

300+getFreePorts n = Socket.withSocketsDo $ do

302 addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")

301 addr:_ <- Socket.getAddrInfo (Just Socket.defaultHints) (Just "127.0.0.1") (Just "0")

303− bracket (open addr) Socket.close Socket.socketPort

302+ bracket (open addr) Socket.close $ \s -> (:) <$> Socket.socketPort s <*> getFreePorts (n - 1)

304 where

303 where

305 open addr = do

304 open addr = do

306 sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)

305 sock <- Socket.socket (Socket.addrFamily addr) (Socket.addrSocketType addr) (Socket.addrProtocol addr)

lib/snap/obelisk-snap.cabaldeleted−40

@@ -1,40 +0,0 @@

1−Name: obelisk-snap

2−Version: 0.1

3−Synopsis: Project Synopsis Here

4−Description: Project Description Here

5−License: BSD3

6−Author: Obsidian Systems

7−Maintainer: maintainer@obsidian.systems

8−Stability: Experimental

9−Category: Web

10−Build-type: Simple

11−Cabal-version: >=1.2

12−

13−library

14− hs-source-dirs: src

15−

16− build-depends:

17− base,

18− bytestring,

19− data-default,

20− diagrams-lib,

21− diagrams-svg,

22− filepath,

23− lens,

24− lucid,

25− monad-control,

26− obelisk-asset-serve-snap,

27− obelisk-snap-extras,

28− semigroups,

29− raw-strings-qq,

30− snap,

31− snap-core,

32− svg-builder,

33− text,

34− transformers-base

35−

36− exposed-modules:

37− Obelisk.Snap

38−

39− other-extensions: TemplateHaskell

40− ghc-options: -threaded -Wall -fno-warn-unused-do-bind -fwarn-tabs -funbox-strict-fields -O2 -fprof-auto-calls -rtsopts

lib/snap/src/Obelisk/Snap.hsdeleted−99

@@ -1,99 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE QuasiQuotes #-}

3−{-# LANGUAGE OverloadedStrings #-}

4−

5−module Obelisk.Snap where

6−

7−import Obelisk.Asset.Serve.Snap

8−import Obelisk.Snap.Extras

9−

10−import Snap

11−

12−import Control.Lens

13−import Data.ByteString (ByteString)

14−import Data.Default

15−import Data.Monoid

16−import qualified Data.Text as T

17−import Lucid

18−import System.FilePath

19−import Control.Monad.IO.Class

20−

21−-- Data type for web app configuration

22−data AppConfig m

23− = AppConfig { _appConfig_initialBody :: m ByteString

24− , _appConfig_initialHead :: ByteString

25− , _appConfig_serveJsexe :: Bool

26− , _appConfig_jsexe :: FilePath

27− }

28−

29−-- Default instance for app configuration

30−instance Monad m => Default (AppConfig m) where

31− def = AppConfig { _appConfig_initialBody = return mempty

32− , _appConfig_initialHead = mempty

33− , _appConfig_serveJsexe = True

34− , _appConfig_jsexe = "frontend.jsexe"

35− }

36−

37−{- | Takes a location, app, and an app configuration as arguements and

38− routes the request to the correct handler. If "appConfig_serveJsexe"

39− returns "True", additional js paths and asset paths will be appended to

40− handler. Otherwise, it will return "404 Not Found" -}

41−serveAppAt :: MonadSnap m => ByteString -> FilePath -> AppConfig m -> m ()

42−serveAppAt loc app cfg = do

43− route $ [ (loc, ifTop $ serveStaticIndex cfg)

44− , (loc, serveAssets (app </> "static.assets") (app </> "static"))

45− , (loc <> "/version", doNotCache >> serveFileIfExistsAs "text/plain" (app </> "version"))

46− ]

47− ++ if _appConfig_serveJsexe cfg

48− then [(loc, serveAssets (app </> frontendJsAssetsPath cfg) (app </> frontendJsPath cfg))]

49− else []

50− ++ [ (loc, doNotCache >> error404) ]

51−

52−-- Helper function used in 'serveAppAt', writes a 404 error message in ByteString

53−error404 :: MonadSnap m => m ()

54−error404 = do

55− modifyResponse $ setResponseCode 404

56− writeBS "404 Not Found"

57−

58−-- Partially applied 'serveAppAt', specialized to the root directory

59−serveApp :: MonadSnap m => FilePath -> AppConfig m -> m ()

60−serveApp = serveAppAt ""

61−

62−-- Helper function used in 'serveAppAt', returns a frontendJs/... filepath

63−frontendJsPath :: AppConfig m -> FilePath

64−frontendJsPath (AppConfig { _appConfig_jsexe = jsexe }) = "frontendJs" </> jsexe

65−

66−-- Helper function used in 'serveAppAt', returns a frontendJs.assets/... filepath

67−frontendJsAssetsPath :: AppConfig m -> FilePath

68−frontendJsAssetsPath (AppConfig { _appConfig_jsexe = jsexe }) = "frontendJs.assets" </> jsexe

69−

70−-- Helper funtion used in 'serveAppAt', writes a lazy bytestring to the body of Http response

71−serveStaticIndex :: MonadSnap m => AppConfig m -> m ()

72−serveStaticIndex cfg = do

73− -- Decode, pack, and append asset target to file path

74− appJsPath <- liftIO $ getAssetPath (frontendJsAssetsPath cfg) "/all.js"

75− initialBody <- _appConfig_initialBody cfg

76− -- Render and write html head and body to response

77− writeLBS $ renderBS $ doctypehtml_ $ do

78− head_ $ do

79− meta_ [charset_ "utf-8"] -- meta-data charset description

80− meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"] -- meta-data viewport description

81− toHtmlRaw $ _appConfig_initialHead cfg

82− body_ $ do -- <body>

83− toHtmlRaw initialBody -- HtmlT monad wrapper

84− script_ [type_ "application/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)

85−

86−{- | Takes an AppConfig monad and uses it to generate & write Lazy ByteString

87− to the body of the https response. This one comes with hard coded values

88− for the logo -}

89−serveIndex :: MonadSnap m => AppConfig m -> m ()

90−serveIndex cfg = do

91− appJsPath <- liftIO $ getAssetPath (frontendJsAssetsPath cfg) "all.js"

92− writeLBS $ renderBS $ doctypehtml_ $ do

93− head_ $ do

94− meta_ [charset_ "utf-8"]

95− meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]

96− body_ $ do

97− script_ [type_ "application/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)

98−

99−makeLenses ''AppConfig

release.nix+77−42

@@ -1,45 +1,80 @@

1{ local-self ? import ./. {}

2−, local-pkgs ? local-self.nixpkgs

3}:

2}:

5−with local-pkgs.lib;

4+let

6−

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

7−genAttrs [ "x86_64-linux" "x86_64-darwin" ] (system: {

7+ cacheBuildSystems = [ "x86_64-linux" "x86_64-darwin" ];

9+ obeliskPackagesCommon = [

10+ "obelisk-frontend"

11+ "obelisk-route"

12+ "obelisk-executable-config"

13+ ];

14+

15+ obeliskPackagesBackend = obeliskPackagesCommon ++ [

16+ "obelisk-asset-manifest"

17+ "obelisk-asset-serve-snap"

18+ "obelisk-backend"

19+ "obelisk-cliapp"

20+ "obelisk-command"

21+ "obelisk-executable-config-inject"

22+ "obelisk-frontend"

23+ "obelisk-run"

24+ "obelisk-route"

25+ "obelisk-selftest"

26+ "obelisk-snap-extras"

27+ ];

28+

29+ pnameToAttrs = pkgsSet: pnames:

30+ lib.listToAttrs (map

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

32+ pnames);

33+

34+ concatDepends = let

35+ extractDeps = x: (x.override {

36+ mkDerivation = drv: {

37+ out = builtins.concatLists [

38+ (drv.buildDepends or [])

39+ (drv.libraryHaskellDepends or [])

40+ (drv.executableHaskellDepends or [])

41+ ];

42+ };

43+ }).out;

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

45+

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

8− inherit (import ./. { inherit system; }) command;

47+ obelisk = import ./. { inherit system; };

9− built-skeleton = (import ./skeleton { inherit system; }).all;

48+ reflex-platform = obelisk.reflex-platform;

10− tests = {

49+ ghc = pnameToAttrs

11− #TODO: Doesn't work; see discussion in https://www.pivotaltracker.com/story/show/157265140

50+ obelisk.haskellPackageSets.ghc

12− # ob-init = runCommand "ob-init" {

51+ obeliskPackagesBackend;

13− # nativeBuildInputs = [

52+ ghcjs = pnameToAttrs

53+ obelisk.haskellPackageSets.ghcjs

54+ obeliskPackagesCommon;

55+ cachePackages = builtins.concatLists [

56+ (builtins.attrValues ghc)

57+ (builtins.attrValues ghcjs)

58+ (concatDepends ghc)

59+ (concatDepends ghcjs)

60+ ];

61+ command = local-self.command;

62+ serverExeSkeleton = (import ./skeleton {}).exe;

63+ builtSkeleton = (import ./skeleton {}).all;

64+ in {

65+ inherit

14− # self.command

66+ command

15− # nix

67+ ghc ghcjs

16− # ];

68+ serverExeSkeleton builtSkeleton;

17− # } ''

69+ cache = reflex-platform.pinBuildInputs

18− # # mkdir $out

70+ "obelisk-${system}"

19− # # cd $out

71+ cachePackages

20− # # ob init --symlink=${self.path}

72+ [command serverExeSkeleton builtSkeleton];

21− #'';

73+ });

22−

74+

23− #TODO: Re-enable this

75+ metaCache = local-self.pinBuildInputs

24− #verify-migration = runCommand "verify-migration" {

25− # nativeBuildInputs = [

26− # self.command

27− # nix # obelisk uses `nix-hash`

28− # ];

29− #} ''

30− # set -e

31− # # Fix permissions so `removePathForcibly` works on copied-to-tmp paths

32− # cp -a ${self.pathGit} $TMPDIR/obelisk

33− # cd $TMPDIR/obelisk

76+ "obelisk-everywhere"

34− # chmod -R u+w .

77+ (map (a: a.cache) (builtins.attrValues perPlatform))

35− #

78+ [];

36− # (set -x;

79+

37− # ob internal hash;

80+in perPlatform // { inherit metaCache; }

38− # ob internal verify-migration;

39− # )

40− #

41− # mkdir -p $out

42− # touch $out/done

43− #'';

44− };

45−})