28cc892 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge branch 'qa' into use-posix-escape

28cc892Elliot Cameron7 years ago

.gitignore+1

compare with master

unifiedsplit

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

2**/.cabal-sandbox

3**/cabal.sandbox.config

4result

5+result-*

5*.o

6*.o

6*.hi

7*.hi

7TAGS

8TAGS

ChangeLog.md+11−11

@@ -2,23 +2,23 @@

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

5−## Unreleased

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

6−

7−* Generalised pathSegmentEncoder, added pathFieldEncoder.

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

8−* Added some Prisms to the encoder library for manipulating DSums (perhaps they should get moved to dependent-sum before release?)

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

9−* Add "ob doc" command, which lists paths to haddock documentation for specified packages

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

10−* Bump reflex-platform so that obelisk now uses GHC 8.6.5 and the nixos-19.03 nixpkgs set

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

11−* Add support in obelisk-route for single parameters in URL paths

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

12−* Bump reflex-platform so that obelisk now uses reflex-dom 0.5.2.0

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

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

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

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

16−* Enable https in `ob run`

16+* Enable HTTPS in `ob run`.

17−* `ob run` now handles ghci errors better, and includes a custom ghcid

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

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

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

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

21−* Ignore package environment files in `ob run` and `ob repl`

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

22* Add `Obelisk.Route.Frontend.routeLinkDynAttr`.

24## v0.2.0.0 - 2019-8-17

default.nix+2−2

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

125 set -euo pipefail

126

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

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

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

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

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

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

130 '';

131 '';

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

132 skeleton = pkgs.runCommand "skeleton" {

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

134 } ''

lib/cliapp/obelisk-cliapp.cabal+1

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

10 ansi-terminal

11 , base

12 , bytestring

13+ , containers

13 , exceptions

14 , exceptions

14 , io-streams

15 , io-streams

15 , lens

16 , lens

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

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

33 , Severity (..)

35 -- .Process

36− , ProcessFailure (..)

37 , AsProcessFailure (..)

36 , AsProcessFailure (..)

38− , readProcessAndLogStderr

37+ , ProcessFailure (..)

39− , readProcessAndLogOutput

38+ , ProcessSpec (..)

40− , readCreateProcessWithExitCode

39+ , callCommand

40+ , callProcess

41 , callProcessAndLogOutput

42 , createProcess_

43− , callProcess

43+ , overCreateProcess

44− , callCommand

44+ , proc

45+ , readCreateProcessWithExitCode

46+ , readProcessAndLogOutput

47+ , readProcessAndLogStderr

45 , reconstructCommand

48 , reconstructCommand

49+ , setCwd

50+ , setDelegateCtlc

51+ , setEnvOverride

52+ , shell

46 ) where

53 ) where

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

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

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

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

8import Control.Monad.IO.Class

9import Data.Semigroup ((<>))

10import qualified Data.Text as T

11−import System.Process (proc)

13import Control.Monad.Catch (MonadMask)

12import Control.Monad.Catch (MonadMask)

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

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

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

10-- and is thus spinner friendly.

11module Obelisk.CliApp.Process

12+ ( AsProcessFailure (..)

12− ( ProcessFailure (..)

13+ , ProcessFailure (..)

13− , AsProcessFailure (..)

14+ , ProcessSpec (..)

14− , readProcessAndLogStderr

15+ , callCommand

15− , readProcessAndLogOutput

16+ , callProcess

16− , readCreateProcessWithExitCode

17 , callProcessAndLogOutput

18 , createProcess

19 , createProcess_

20− , callProcess

20+ , overCreateProcess

21− , callCommand

21+ , proc

22+ , readCreateProcessWithExitCode

23+ , readProcessAndLogOutput

24+ , readProcessAndLogStderr

22 , reconstructCommand

25 , reconstructCommand

26+ , setCwd

27+ , setDelegateCtlc

28+ , setEnvOverride

29+ , shell

23 ) where

30 ) where

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

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

@@ -31,18 +38,20 @@ import qualified Data.ByteString as BS

31import qualified Data.ByteString.Char8 as BSC

38import qualified Data.ByteString.Char8 as BSC

32import qualified Data.ByteString.UTF8 as BSU

39import qualified Data.ByteString.UTF8 as BSU

33import Data.Function (fix)

40import Data.Function (fix)

41+import Data.Map (Map)

42+import qualified Data.Map as Map

34import Data.Monoid ((<>))

43import Data.Monoid ((<>))

35import Data.Text (Text)

44import Data.Text (Text)

36import qualified Data.Text as T

45import qualified Data.Text as T

37import qualified Data.Text.Encoding as T

46import qualified Data.Text.Encoding as T

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

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

48+import System.Environment (getEnvironment)

39import System.Exit (ExitCode (..))

49import System.Exit (ExitCode (..))

40import System.IO (Handle)

50import System.IO (Handle)

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

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

42import qualified System.IO.Streams as Streams

52import qualified System.IO.Streams as Streams

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

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

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

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

45− waitForProcess)

46import qualified System.Process as Process

55import qualified System.Process as Process

47import Text.ShellEscape (bytes, bash)

56import Text.ShellEscape (bytes, bash)

@@ -50,6 +59,30 @@ import Control.Monad.Log (Severity (..))

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

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

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

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

62+data ProcessSpec = ProcessSpec

63+ { _processSpec_createProcess :: !CreateProcess

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

65+ }

66+

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

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

69+

70+shell :: String -> ProcessSpec

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

72+

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

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

75+

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

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

78+

79+setDelegateCtlc :: Bool -> ProcessSpec -> ProcessSpec

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

81+

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

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

84+

85+

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

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

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

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

55 deriving Show

88 deriving Show

@@ -64,7 +97,7 @@ instance AsProcessFailure ProcessFailure where

65readProcessAndLogStderr

98readProcessAndLogStderr

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

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

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

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

68readProcessAndLogStderr sev process = do

101readProcessAndLogStderr sev process = do

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

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

70 streamToLog =<< liftIO (streamHandle sev err)

103 streamToLog =<< liftIO (streamHandle sev err)

@@ -72,9 +105,10 @@ readProcessAndLogStderr sev process = do

105

73readCreateProcessWithExitCode

106readCreateProcessWithExitCode

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

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

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

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

76−readCreateProcessWithExitCode process = do

109+readCreateProcessWithExitCode procSpec = do

110+ process <- mkCreateProcess procSpec

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

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

78 liftIO $ Process.readCreateProcessWithExitCode process ""

112 liftIO $ Process.readCreateProcessWithExitCode process ""

113

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

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

@@ -86,10 +120,10 @@ readCreateProcessWithExitCode process = do

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

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

87readProcessAndLogOutput

121readProcessAndLogOutput

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

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

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

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

90readProcessAndLogOutput (sev_out, sev_err) process = do

124readProcessAndLogOutput (sev_out, sev_err) process = do

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

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

92− { std_out = CreatePipe , std_err = CreatePipe }

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

127

94 -- TODO interleave stdout and stderr in log correctly

128 -- TODO interleave stdout and stderr in log correctly

95 streamToLog =<< liftIO (streamHandle sev_err err)

129 streamToLog =<< liftIO (streamHandle sev_err err)

@@ -98,9 +132,9 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

132

99 liftIO (waitForProcess p) >>= \case

133 liftIO (waitForProcess p) >>= \case

100 ExitSuccess -> pure outText

134 ExitSuccess -> pure outText

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

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

102

136

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

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

104-- with the corresponding severity.

138-- with the corresponding severity.

105--

139--

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

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

@@ -108,9 +142,8 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

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

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

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

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

110callProcessAndLogOutput

144callProcessAndLogOutput

111−

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

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

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

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

114callProcessAndLogOutput (sev_out, sev_err) process =

147callProcessAndLogOutput (sev_out, sev_err) process =

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

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

116 stream <- liftIO $ join $ combineStream

149 stream <- liftIO $ join $ combineStream

@@ -120,21 +153,31 @@ callProcessAndLogOutput (sev_out, sev_err) process =

120 where

153 where

121 combineStream s1 s2 = concurrentMerge [s1, s2]

154 combineStream s1 s2 = concurrentMerge [s1, s2]

122

155

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

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

124createProcess

157createProcess

125 :: (MonadIO m, CliLog m)

158 :: (MonadIO m, CliLog m)

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

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

127−createProcess p = do

160+createProcess procSpec = do

161+ p <- mkCreateProcess procSpec

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

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

129 liftIO $ Process.createProcess p

163 liftIO $ Process.createProcess p

130

164

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

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

132createProcess_

166createProcess_

133 :: (MonadIO m, CliLog m)

167 :: (MonadIO m, CliLog m)

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

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

135−createProcess_ name p = do

169+createProcess_ name procSpec = do

170+ p <- mkCreateProcess procSpec

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

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

137− liftIO $ Process.createProcess p

172+ liftIO $ Process.createProcess_ name p

173+

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

175+mkCreateProcess (ProcessSpec p override') = do

176+ case override' of

177+ Nothing -> pure p

178+ Just override -> do

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

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

138

181

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

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

140callProcess

183callProcess

@@ -154,17 +197,17 @@ callCommand cmd = do

154

197

155withProcess

198withProcess

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

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

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

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

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

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

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

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

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

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

161− { std_out = CreatePipe , std_err = CreatePipe }

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

162

205

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

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

164

207

165 liftIO (waitForProcess p) >>= \case

208 liftIO (waitForProcess p) >>= \case

166 ExitSuccess -> return (out, err)

209 ExitSuccess -> return (out, err)

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

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

168

211

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

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

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

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

@@ -181,8 +224,12 @@ streamToLog stream = fix $ \loop -> do

181

224

182-- | Pretty print a 'CmdSpec'

225-- | Pretty print a 'CmdSpec'

183reconstructCommand :: Process.CmdSpec -> Text

226reconstructCommand :: Process.CmdSpec -> Text

227+reconstructCommand p = case p of

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

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

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

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

186 where

230 where

187 processToShellString cmd args = T.pack $ unwords $

231 processToShellString cmd args = T.pack $ unwords $

188 map (BSU.toString . bytes . bash . BSU.fromString) (cmd : args)

232 map (BSU.toString . bytes . bash . BSU.fromString) (cmd : args)

233+

234+reconstructProcSpec :: ProcessSpec -> Text

235+reconstructProcSpec = reconstructCommand . Process.cmdspec . _processSpec_createProcess

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

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

1name: obelisk-command

2−version: 0.1

2+version: 0.3

3cabal-version: >= 1.8

4build-type: Simple

lib/command/src/Obelisk/Command.hs+28−13

@@ -14,6 +14,7 @@ import Data.Bool (bool)

14import qualified Data.ByteString.Base16 as Base16

15import qualified Data.ByteString.Lazy as LBS

16import qualified Data.ByteString.UTF8 as BSU

17+import Data.Foldable (for_)

17import Data.List

18import Data.List

18import Data.Maybe (catMaybes)

19import Data.Maybe (catMaybes)

19import qualified Data.Text as T

20import qualified Data.Text as T

@@ -222,20 +223,35 @@ thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgumen

222 , help "Path to directory containing thunk data"

223 , help "Path to directory containing thunk data"

223 ]

224 ]

224

225

226+thunkConfig :: Parser ThunkConfig

227+thunkConfig = ThunkConfig

228+ <$>

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

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

231+ <|> pure Nothing

232+ )

233+

234+thunkUpdateConfig :: Parser ThunkUpdateConfig

235+thunkUpdateConfig = ThunkUpdateConfig

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

237+ <*> thunkConfig

238+

239+thunkPackConfig :: Parser ThunkPackConfig

240+thunkPackConfig = ThunkPackConfig

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

242+ <*> thunkConfig

243+

225data ThunkCommand

244data ThunkCommand

226− = ThunkCommand_Update [FilePath] (Maybe String)

245+ = ThunkCommand_Update [FilePath] ThunkUpdateConfig

227 | ThunkCommand_Unpack [FilePath]

246 | ThunkCommand_Unpack [FilePath]

228− | ThunkCommand_Pack [FilePath] Bool

247+ | ThunkCommand_Pack [FilePath] ThunkPackConfig

229 deriving Show

248 deriving Show

230

249

231−forceFlag :: Parser Bool

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

233−

234thunkCommand :: Parser ThunkCommand

250thunkCommand :: Parser ThunkCommand

235thunkCommand = hsubparser $ mconcat

251thunkCommand = hsubparser $ mconcat

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

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

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

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

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

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

239 ]

255 ]

240

256

241data ShellOpts

257data ShellOpts

@@ -376,17 +392,16 @@ ob = \case

376 DeployCommand_Update -> deployUpdate "."

392 DeployCommand_Update -> deployUpdate "."

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

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

378 ObCommand_Run -> inNixShell' $ static run

394 ObCommand_Run -> inNixShell' $ static run

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

380 ObCommand_Thunk tc -> case tc of

395 ObCommand_Thunk tc -> case tc of

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

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

382− ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

397+ ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

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

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

384 ObCommand_Repl -> runRepl

399 ObCommand_Repl -> runRepl

385 ObCommand_Watch -> inNixShell' $ static runWatch

400 ObCommand_Watch -> inNixShell' $ static runWatch

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

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

387 projectProc root False (_shellOpts_shell so) (pure . bash . BSU.fromString <$> _shellOpts_command so)

402 projectProc root False (_shellOpts_shell so) (pure . bash . BSU.fromString <$> _shellOpts_command so)

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

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

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

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

390 ObCommand_Internal icmd -> case icmd of

405 ObCommand_Internal icmd -> case icmd of

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

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

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

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

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

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

25import Nix.String (principledMakeNixStringWithoutContext)

26import Nix.Value

27import System.Directory

28−import System.Environment (getEnvironment)

29import System.FilePath

28import System.FilePath

30import System.IO

29import System.IO

31import System.Posix.Files

30import System.Posix.Files

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

33import Text.URI (URI)

31import Text.URI (URI)

34import qualified Text.URI as URI

32import qualified Text.URI as URI

35import Text.URI.Lens

33import Text.URI.Lens

37import Obelisk.App (MonadObelisk)

35import Obelisk.App (MonadObelisk)

36+import Obelisk.CliApp (

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

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

38+ setCwd, setDelegateCtlc, setEnvOverride, withSpinner)

39import Obelisk.Command.Nix

40import Obelisk.Command.Project

41import Obelisk.Command.Thunk

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

82 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames

83 writeDeployConfig deployDir "enable_https" $ show enableHttps

84 writeDeployConfig deployDir "admin_email" adminEmail

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

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

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

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

88 setupObeliskImpl deployDir

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

107 Right (ThunkData_Packed ptr) -> return ptr

108 Right (ThunkData_Checkout _) -> do

109 checkGitCleanStatus srcPath True >>= \case

110− True -> packThunk False srcPath

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

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

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

113 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr

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

157 ]

158 isClean <- checkGitCleanStatus deployPath True

159 when (not isClean) $ do

160− withSpinner "Commiting changes to Git" $ do

160+ withSpinner "Committing changes to Git" $ do

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

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

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

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

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

166 where

167 callProcess' envMap cmd args = do

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

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

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

170 callProcessAndLogOutput (Notice, Notice) p

169 callProcessAndLogOutput (Notice, Notice) p

171

170

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

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

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

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

174

173

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

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

176keytoolToAndroidConfig conf =

175keytoolToAndroidConfig conf =

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

219 , _keytoolConfig_storepass = keyStorePassword

218 , _keytoolConfig_storepass = keyStorePassword

220 , _keytoolConfig_keypass = keyStorePassword

219 , _keytoolConfig_keypass = keyStorePassword

221 }

220 }

222− createKeystore root $ keyToolConf

221+ createKeystore root keyToolConf

223 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

222 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

224 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

223 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

225 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

224 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

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

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

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

276createKeystore root config = do

275createKeystore root config = do

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

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

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

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

279 where

278 where

280 keytoolCmd = processToShellString "keytool"

279 keytoolCmd = processToShellString "keytool"

281 [ "-genkeypair", "-noprompt"

280 [ "-genkeypair", "-noprompt"

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

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

37import Data.Maybe

38import Data.Monoid ((<>))

39import qualified Data.Text as T

40−import System.Process (proc)

42import Obelisk.App (MonadObelisk)

41import Obelisk.App (MonadObelisk)

43import Obelisk.CliApp

42import Obelisk.CliApp

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

160

159

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

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

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

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

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

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

164 -- Remove final newline that Nix appends

163 -- Remove final newline that Nix appends

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

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

166 pure $ T.unpack outPath

165 pure $ T.unpack outPath

lib/command/src/Obelisk/Command/Project.hs+6−11

@@ -33,9 +33,9 @@ import System.IO.Temp

33import System.IO.Unsafe (unsafePerformIO)

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

35import System.Posix.Files

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

36+import System.Process (waitForProcess)

37−import Text.ShellEscape (Bash, bytes)

38import System.Which (staticWhich)

37import System.Which (staticWhich)

38+import Text.ShellEscape (Bash, bytes)

40import GitHub.Data.GitData (Branch)

41import GitHub.Data.Name (Name)

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

57 { _gitHubSource_owner = "obsidiansystems"

58 , _gitHubSource_repo = "obelisk"

59 , _gitHubSource_branch = Just branch

60+ , _gitHubSource_private = False

60 }

61 }

62data InitSource

63data InitSource

@@ -172,7 +173,7 @@ findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

172findProjectRoot target = do

173findProjectRoot target = do

173 myUid <- liftIO getRealUserID

174 myUid <- liftIO getRealUserID

174 targetStat <- liftIO $ getFileStatus target

175 targetStat <- liftIO $ getFileStatus target

175− umask <- liftIO $ getUmask

176+ umask <- liftIO getUmask

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

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

177 return result

178 return result

178

179

@@ -259,9 +260,9 @@ projectProc root isPure shellName command =

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

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

260projectShell root isPure shellName command = do

261projectShell root isPure shellName command = do

261 let nixPath = $(staticWhich "nix")

262 let nixPath = $(staticWhich "nix")

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

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

263 nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"

264 nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"

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

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

265 [ "default.nix"] <>

266 [ "default.nix"] <>

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

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

267 [ "-A"

268 [ "-A"

@@ -276,9 +277,3 @@ projectShell root isPure shellName command = do

276 c

277 c

277 ]

278 ]

278 void $ liftIO $ waitForProcess ph

279 void $ liftIO $ waitForProcess ph

279−

280−setCtlc :: CreateProcess -> CreateProcess

281−setCtlc cfg = cfg { delegate_ctlc = True }

282−

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

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

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

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

33import Network.Socket hiding (Debug)

34import System.Directory

35import System.FilePath

36−import System.Process (proc)

37import System.IO.Temp (withSystemTempDirectory)

36import System.IO.Temp (withSystemTempDirectory)

38import System.Which (staticWhich)

37import System.Which (staticWhich)

39import Text.ShellEscape (bash, bytes)

38import Text.ShellEscape (bash, bytes)

@@ -41,7 +40,7 @@ import Text.ShellEscape (bash, bytes)

41import Obelisk.App (MonadObelisk, ObeliskT)

40import Obelisk.App (MonadObelisk, ObeliskT)

42import Obelisk.CliApp

41import Obelisk.CliApp

43 ( CliT (..), HasCliConfig, Severity (..)

42 ( CliT (..), HasCliConfig, Severity (..)

44− , callCommand, failWith, getCliConfig, putLog

43+ , callCommand, failWith, getCliConfig, putLog, proc

45 , readProcessAndLogStderr, runCli)

44 , readProcessAndLogStderr, runCli)

46import Obelisk.Command.Project (inProjectProc, withProjectRoot)

45import Obelisk.Command.Project (inProjectProc, withProjectRoot)

@@ -134,7 +133,9 @@ parseCabalPackage dir = do

134 return Nothing

133 return Nothing

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

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

136 return $ Just $ renderPackage [] hpackPackage

135 return $ Just $ renderPackage [] hpackPackage

136+ else do

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

137− else return Nothing

138+ return Nothing

138

139

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

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

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

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

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

168withGhciScript

169withGhciScript

169 :: MonadObelisk m

170 :: MonadObelisk m

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

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

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

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

172 -> m ()

173 -> m ()

173withGhciScript pkgs f = do

174withGhciScript pkgs f = do

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

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

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

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

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TypeApplications #-}

10module Obelisk.Command.Thunk

11+ ( GitHubSource (..)

12+ , GitUri (..)

13+ , ReadThunkError (..)

14+ , ThunkConfig (..)

15+ , ThunkData (..)

16+ , ThunkPackConfig (..)

11− ( ThunkPtr (..)

17+ , ThunkPtr (..)

12 , ThunkRev (..)

18 , ThunkRev (..)

13 , ThunkSource (..)

19 , ThunkSource (..)

14− , ThunkData (..)

20+ , ThunkUpdateConfig (..)

15− , ReadThunkError (..)

16− , GitHubSource (..)

17− , getThunkGitBranch

18− , getLatestRev

19− , updateThunkToLatest

20 , createThunk

21 , createThunk

21 , createThunkWithLatest

22 , createThunkWithLatest

23+ , getLatestRev

24+ , getThunkGitBranch

25+ , getThunkPtr

26+ , gitUriToText

22 , nixBuildAttrWithCache

27 , nixBuildAttrWithCache

23 , nixBuildThunkAttrWithCache

28 , nixBuildThunkAttrWithCache

24− , unpackThunk

25 , packThunk

29 , packThunk

30+ , parseGitUri

26 , readThunk

31 , readThunk

32+ , unpackThunk

27 , updateThunk

33 , updateThunk

28− , getThunkPtr

34+ , updateThunkToLatest

29− , parseGitUri

30 , uriThunkPtr

35 , uriThunkPtr

31 ) where

36 ) where

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

68import System.IO.Error

73import System.IO.Error

69import System.IO.Temp

74import System.IO.Temp

70import System.Posix (getSymbolicLinkStatus, modificationTime)

75import System.Posix (getSymbolicLinkStatus, modificationTime)

71−import System.Process (proc)

76+import qualified Text.URI as URI

72−import Text.URI

74import Obelisk.App (MonadObelisk)

78import Obelisk.App (MonadObelisk)

75import Obelisk.CliApp

79import Obelisk.CliApp

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

111 { _gitHubSource_owner :: Name Owner

115 { _gitHubSource_owner :: Name Owner

112 , _gitHubSource_repo :: Name Repo

116 , _gitHubSource_repo :: Name Repo

113 , _gitHubSource_branch :: Maybe (Name Branch)

117 , _gitHubSource_branch :: Maybe (Name Branch)

118+ , _gitHubSource_private :: Bool

114 }

119 }

115 deriving (Show, Eq, Ord)

120 deriving (Show, Eq, Ord)

116

121

122+newtype GitUri = GitUri URI.URI deriving (Eq, Ord, Show)

123+

124+gitUriToText :: GitUri -> Text

125+gitUriToText (GitUri uri)

126+ | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"

127+ , Just (_, path) <- URI.uriPath uri

128+ = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)

129+ | otherwise = URI.render uri

130+

117data GitSource = GitSource

131data GitSource = GitSource

118− { _gitSource_url :: URI

132+ { _gitSource_url :: GitUri

119 , _gitSource_branch :: Maybe (Name Branch)

133 , _gitSource_branch :: Maybe (Name Branch)

120 , _gitSource_fetchSubmodules :: Bool

134 , _gitSource_fetchSubmodules :: Bool

135+ , _gitSource_private :: Bool

121 }

136 }

122 deriving (Show, Eq, Ord)

137 deriving (Show, Eq, Ord)

123

138

139+newtype ThunkConfig = ThunkConfig

140+ { _thunkConfig_private :: Maybe Bool

141+ } deriving Show

142+

143+data ThunkUpdateConfig = ThunkUpdateConfig

144+ { _thunkUpdateConfig_branch :: Maybe String

145+ , _thunkUpdateConfig_config :: ThunkConfig

146+ } deriving Show

147+

148+data ThunkPackConfig = ThunkPackConfig

149+ { _thunkPackConfig_force :: Bool

150+ , _thunkPackConfig_config :: ThunkConfig

151+ } deriving Show

152+

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

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

125forgetGithub :: Bool -> GitHubSource -> GitSource

154forgetGithub :: Bool -> GitHubSource -> GitSource

126forgetGithub useSsh s = GitSource

155forgetGithub useSsh s = GitSource

127− { _gitSource_url = URI

156+ { _gitSource_url = GitUri $ URI.URI

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

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

129− , uriAuthority = Right $ Authority

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

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

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

131 <$ guard useSsh

160 <$ guard useSsh

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

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

133− , authPort = Nothing

162+ , URI.authPort = Nothing

134 }

163 }

135− , uriPath = Just ( False

164+ , URI.uriPath = Just ( False

136− , fromRight' . mkPathPiece <$>

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

137 untagName (_gitHubSource_owner s)

166 untagName (_gitHubSource_owner s)

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

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

139 )

168 )

140− , uriQuery = []

169+ , URI.uriQuery = []

141− , uriFragment = Nothing

170+ , URI.uriFragment = Nothing

142 }

171 }

143 , _gitSource_branch = _gitHubSource_branch s

172 , _gitSource_branch = _gitHubSource_branch s

144 , _gitSource_fetchSubmodules = False

173 , _gitSource_fetchSubmodules = False

174+ , _gitSource_private = _gitHubSource_private s

145 }

175 }

146

176

147getThunkGitBranch :: ThunkPtr -> Maybe Text

177getThunkGitBranch :: ThunkPtr -> Maybe Text

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

155-- TODO: Use spinner here.

185-- TODO: Use spinner here.

156getNixSha256ForUriUnpacked

186getNixSha256ForUriUnpacked

157 :: MonadObelisk m

187 :: MonadObelisk m

158− => URI

188+ => GitUri

159 -> m NixSha256

189 -> m NixSha256

160getNixSha256ForUriUnpacked uri =

190getNixSha256ForUriUnpacked uri =

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

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

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

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

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

193+ proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]

164 pure hash

194 pure hash

165

195

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

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

167nixPrefetchGit uri rev fetchSubmodules =

197nixPrefetchGit uri rev fetchSubmodules =

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

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

169 out <- readProcessAndLogStderr Debug $

199 out <- readProcessAndLogStderr Debug $

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

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

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

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

172 , "--rev", T.unpack rev

202 , "--rev", T.unpack rev

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

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

174 , "--quiet"

204 , "--quiet"

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

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

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

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

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

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

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

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

289 pure $ GitHubSource

320 pure $ GitHubSource

290 { _gitHubSource_owner = owner

321 { _gitHubSource_owner = owner

291 , _gitHubSource_repo = repo

322 , _gitHubSource_repo = repo

292 , _gitHubSource_branch = branch

323 , _gitHubSource_branch = branch

324+ , _gitHubSource_private = fromMaybe False private

293 }

325 }

294

326

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

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

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

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

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

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

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

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

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

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

300 pure $ GitSource

333 pure $ GitSource

301 { _gitSource_url = url

334 { _gitSource_url = url

302 , _gitSource_branch = branch

335 , _gitSource_branch = branch

303 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules

336 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules

337+ , _gitSource_private = fromMaybe False private

304 }

338 }

305

339

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

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

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

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

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

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

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

329 , Just $ "sha256" .= _thunkRev_nixSha256 rev

363 , Just $ "sha256" .= _thunkRev_nixSha256 rev

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

330 ]

365 ]

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

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

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

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

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

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

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

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

335 , Just $ "sha256" .= _thunkRev_nixSha256 rev

370 , Just $ "sha256" .= _thunkRev_nixSha256 rev

336 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

371 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

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

337 ]

373 ]

338 where

374 where

339 githubCfg = defConfig

375 githubCfg = defConfig

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

354 [ "url"

390 [ "url"

355 , "rev"

391 , "rev"

356 , "sha256"

392 , "sha256"

393+ , "private"

357 , "fetchSubmodules"

394 , "fetchSubmodules"

358 ] <> compare

395 ] <> compare

359 , confTrailingNewline = True

396 , confTrailingNewline = True

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

377 , _thunkPtr_rev = rev

414 , _thunkPtr_rev = rev

378 }

415 }

379

416

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

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

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

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

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

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

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

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

384 case mBranch of

421 case mBranch of

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

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

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

391 let src = _thunkPtr_source ptr

428 let src = _thunkPtr_source ptr

392 rev <- getLatestRev src

429 rev <- getLatestRev src

393− overwriteThunk overwrite $ ThunkPtr

430+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr

394 { _thunkPtr_source = src

431 { _thunkPtr_source = src

395 , _thunkPtr_rev = rev

432 , _thunkPtr_rev = rev

396 }

433 }

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

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

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

399 Right c -> case c of

436 Right c -> case c of

400 ThunkData_Packed t -> case _thunkPtr_source t of

437 ThunkData_Packed t -> case _thunkPtr_source t of

401− ThunkSource_Git tsg -> setThunk target tsg branch

438+ ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch

402 ThunkSource_GitHub tsgh -> do

439 ThunkSource_GitHub tsgh -> do

403 let tsg = forgetGithub False tsgh

440 let tsg = forgetGithub False tsgh

404− setThunk target tsg branch

441+ setThunk thunkConfig target tsg branch

405− ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> (show target) <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."

442+ ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> show target <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."

406

443

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

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

408−setThunk target gs branch = do

445+setThunk thunkConfig target gs branch = do

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

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

410 overwriteThunk target newThunkPtr

447 overwriteThunk target newThunkPtr

411− updateThunkToLatest target Nothing

448+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target

412

449

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

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

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

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

415gitHubStandaloneLoaders :: NonEmpty Text

452gitHubStandaloneLoaders :: NonEmpty Text

416gitHubStandaloneLoaders =

453gitHubStandaloneLoaders =

417− gitHubStandaloneLoaderV2 :|

454+ gitHubStandaloneLoaderV4 :|

418 [ gitHubStandaloneLoaderV3

455 [ gitHubStandaloneLoaderV3

456+ , gitHubStandaloneLoaderV2

419 , gitHubStandaloneLoaderV1

457 , gitHubStandaloneLoaderV1

420 ]

458 ]

421

459

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

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

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

456 ]

494 ]

457

495

496+gitHubStandaloneLoaderV4 :: Text

497+gitHubStandaloneLoaderV4 = T.unlines

498+ [ "# DO NOT HAND-EDIT THIS FILE"

499+ , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"

500+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"

501+ , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"

502+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"

503+ , " inherit owner repo rev sha256 fetchSubmodules private;"

504+ , " };"

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

506+ ]

507+

458plainGitStandaloneLoaders :: NonEmpty Text

508plainGitStandaloneLoaders :: NonEmpty Text

459plainGitStandaloneLoaders =

509plainGitStandaloneLoaders =

460− plainGitStandaloneLoaderV1 :|

510+ plainGitStandaloneLoaderV3 :|

511+ [ plainGitStandaloneLoaderV1

461− [ plainGitStandaloneLoaderV2

512+ , plainGitStandaloneLoaderV2

462 ]

513 ]

463

514

464plainGitStandaloneLoaderV1 :: Text

515plainGitStandaloneLoaderV1 :: Text

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

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

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

480 ]

531 ]

481

532

533+plainGitStandaloneLoaderV3 :: Text

534+plainGitStandaloneLoaderV3 = T.unlines

535+ [ "# DO NOT HAND-EDIT THIS FILE"

536+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

537+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

538+ , " if firstChar == \"/\" then /. + url"

539+ , " else if firstChar == \".\" then ./. + url"

540+ , " else url;"

541+ , " in if !fetchSubmodules && private then builtins.fetchGit {"

542+ , " url = realUrl; inherit rev;"

543+ , " } else (import <nixpkgs> {}).fetchgit {"

544+ , " url = realUrl; inherit rev sha256;"

545+ , " };"

546+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

547+ ]

548+

482thunkFileNames :: [FilePath]

549thunkFileNames :: [FilePath]

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

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

484

551

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

520 Just c -> return c

587 Just c -> return c

521 Nothing -> do

588 Nothing -> do

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

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

523− _ <- nixCmd $ NixCmd_Build$ def

590+ _ <- nixCmd $ NixCmd_Build $ def

524 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

591 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

525 Lens.& nixCmdConfig_target Lens..~ Target

592 Lens.& nixCmdConfig_target Lens..~ Target

526 { _target_path = Just thunkDir

593 { _target_path = Just thunkDir

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

570 callProcessAndLogOutput (Notice, Error) $

637 callProcessAndLogOutput (Notice, Error) $

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

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

572 return tmpThunk

639 return tmpThunk

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

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

574 updateThunkFromTmp p' = do

641 updateThunkFromTmp p' = do

575− _ <- packThunk' True False p'

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

576 callProcessAndLogOutput (Notice, Error) $

643 callProcessAndLogOutput (Notice, Error) $

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

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

578

645

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

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

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

607 git $ [ "clone" ]

674 git $ [ "clone" ]

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

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

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

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

610 ++ do branch <- maybeToList $ _gitSource_branch s

677 ++ do branch <- maybeToList $ _gitSource_branch s

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

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

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

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

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

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

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

623

690

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

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

625−packThunk :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr

692+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr

626packThunk = packThunk' False

693packThunk = packThunk' False

627

694

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

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

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

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

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

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

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

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

632 Right (ThunkData_Checkout _) -> do

699 Right (ThunkData_Checkout _) -> do

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

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

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

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

635− thunkPtr <- getThunkPtr (not force) thunkDir

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

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

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

637 liftIO $ createThunk thunkDir thunkPtr

704 liftIO $ createThunk thunkDir thunkPtr

638 pure thunkPtr

705 pure thunkPtr

639

706

707+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr

708+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of

709+ Nothing -> ptr

710+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of

711+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }

712+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }

713+ }

714+

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

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

641getThunkPtr checkClean thunkDir = do

716getThunkPtr checkClean thunkDir = do

642− when checkClean $ ensureCleanGitRepo thunkDir True $

717+ when checkClean $ ensureCleanGitRepo thunkDir True

643 "thunk pack: thunk checkout contains unsaved modifications"

718 "thunk pack: thunk checkout contains unsaved modifications"

644

719

645 -- Check whether there are any stashes

720 -- Check whether there are any stashes

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

661 <$> T.lines

736 <$> T.lines

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

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

663 case b of

738 case b of

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

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

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

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

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

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

667 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."

742 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."

@@ -733,7 +808,7 @@ getThunkPtr checkClean thunkDir = do

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

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

734 , ""

809 , ""

735 ] ++

810 ] ++

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

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

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

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

738 [ ""

813 [ ""

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

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

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

741 ]

816 ]

742

817

743 -- We assume it's safe to pack the thunk at this point

818 -- We assume it's safe to pack the thunk at this point

744− putLog Informational $ "All changes safe in git remotes. OK to pack thunk."

819+ putLog Informational "All changes safe in git remotes. OK to pack thunk."

745

820

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

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

747

822

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

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

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

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

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

775-- a regular git thunk.

850-- a regular git thunk.

776−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr

851+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Text -> Maybe Text -> m ThunkPtr

777uriThunkPtr uri mbranch mcommit = do

852uriThunkPtr uri mbranch mcommit = do

778 commit <- case mcommit of

853 commit <- case mcommit of

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

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

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

784 case rev of

859 case rev of

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

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

786 Left e -> do

861 Left e -> do

787− putLog Warning $ "\

862+ putLog Warning "\

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

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

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

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

790 errorToWarning e

865 errorToWarning e

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

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

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

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

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

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

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

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

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

805−uriToThunkSource u

880+uriToThunkSource (GitUri u)

806− | Right uriAuth <- uriAuthority u

881+ | Right uriAuth <- URI.uriAuthority u

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

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

808 , case scheme of

883 , case scheme of

809− "ssh" -> uriAuth == Authority

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

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

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

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

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

812− , authPort = Nothing

887+ , URI.authPort = Nothing

813 }

888 }

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

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

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

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

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

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

817 = \mbranch -> ThunkSource_GitHub $ GitHubSource

892 = \mbranch -> ThunkSource_GitHub $ GitHubSource

818− { _gitHubSource_owner = N $ unRText owner

893+ { _gitHubSource_owner = N $ URI.unRText owner

819 , _gitHubSource_repo = N $ let

894 , _gitHubSource_repo = N $ let

820− repoish' = unRText repoish

895+ repoish' = URI.unRText repoish

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

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

822− Just repo -> repo

823− Nothing -> repoish'

824 , _gitHubSource_branch = N <$> mbranch

897 , _gitHubSource_branch = N <$> mbranch

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

825 }

899 }

826

900

827 | otherwise = \mbranch -> ThunkSource_Git $ GitSource

901 | otherwise = \mbranch -> ThunkSource_Git $ GitSource

828− { _gitSource_url = u

902+ { _gitSource_url = GitUri u

829 , _gitSource_branch = N <$> mbranch

903 , _gitSource_branch = N <$> mbranch

830 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?

904 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?

905+ , _gitSource_private = False -- TODO: Can we try something to infer this?

831 }

906 }

832

907

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

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

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

840githubThunkRev s commit = do

915githubThunkRev s commit = do

841 owner <- forcePP $ _gitHubSource_owner s

916 owner <- forcePP $ _gitHubSource_owner s

842 repo <- forcePP $ _gitHubSource_repo s

917 repo <- forcePP $ _gitHubSource_repo s

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

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

844− let archiveUri = URI

919+ let archiveUri = GitUri $ URI.URI

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

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

846− , uriAuthority = Right $ Authority

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

847− { authUserInfo = Nothing

922+ { URI.authUserInfo = Nothing

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

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

849− , authPort = Nothing

924+ , URI.authPort = Nothing

850 }

925 }

851− , uriPath = Just ( False

926+ , URI.uriPath = Just ( False

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

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

853 )

928 )

854− , uriQuery = []

929+ , URI.uriQuery = []

855− , uriFragment = Nothing

930+ , URI.uriFragment = Nothing

856 }

931 }

857 hash <- getNixSha256ForUriUnpacked archiveUri

932 hash <- getNixSha256ForUriUnpacked archiveUri

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

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

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

861 , _thunkRev_nixSha256 = hash

936 , _thunkRev_nixSha256 = hash

862 }

937 }

863 where

938 where

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

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

865− forcePP = mkPathPiece . untagName

940+ forcePP = URI.mkPathPiece . untagName

866

941

867gitThunkRev

942gitThunkRev

868 :: MonadObelisk m

943 :: MonadObelisk m

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

871 -> m ThunkRev

946 -> m ThunkRev

872gitThunkRev s commit = do

947gitThunkRev s commit = do

873 let u = _gitSource_url s

948 let u = _gitSource_url s

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

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

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

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

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

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

877 failWith $ "obelisk currently only supports "

952 failWith $ "obelisk currently only supports "

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

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

879 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s

954 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s

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

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

881 pure $ ThunkRev

956 pure $ ThunkRev

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

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

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

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

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

891gitGetCommitBranch

966gitGetCommitBranch

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

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

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

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

894 (_, bothMaps) <- gitLsRemote

969 (_, bothMaps) <- gitLsRemote

895− (T.unpack $ render uri)

970+ (T.unpack $ gitUriToText uri)

896 (GitRef_Branch <$> mbranch)

971 (GitRef_Branch <$> mbranch)

897 Nothing

972 Nothing

898 branch <- case mbranch of

973 branch <- case mbranch of

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

908 pure (branch, commit)

983 pure (branch, commit)

909 where

984 where

910 rethrowE = either failWith pure

985 rethrowE = either failWith pure

911− uriMsg = render uri

986+ uriMsg = gitUriToText uri

987+

988+parseGitUri :: Text -> Maybe GitUri

989+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)

912

990

913−parseGitUri :: Text -> Maybe URI

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

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

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

915

993

916−parseAbsoluteURI :: Text -> Maybe URI

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

917parseAbsoluteURI uri = do

995parseAbsoluteURI uri = do

918− parsedUri <- mkURI uri

996+ parsedUri <- URI.mkURI uri

919− guard $ isPathAbsolute parsedUri

997+ guard $ URI.isPathAbsolute parsedUri

920− pure $ parsedUri

998+ pure parsedUri

921

999

922−parseSshShorthand :: Text -> Maybe URI

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

923parseSshShorthand uri = do

1001parseSshShorthand uri = do

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

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

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

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

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

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

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

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

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

934 && not (T.null colonAndPath)

1012 && not (T.null colonAndPath)

935− mkURI properUri

1013+ URI.mkURI properUri

lib/command/src/Obelisk/Command/Utils.hs+22−13

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

23import System.Directory (canonicalizePath)

24import System.Environment (getExecutablePath)

25import System.Exit (ExitCode)

26−import qualified System.Process as P

27import Text.Megaparsec as MP

26import Text.Megaparsec as MP

28import Text.Megaparsec.Char as MP

27import Text.Megaparsec.Char as MP

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

61 git ["add", "."]

60 git ["add", "."]

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

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

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

63+gitProcNoRepo :: [String] -> ProcessSpec

65−gitProcNoRepo = P.proc "git"

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

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

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

68gitProc repo = gitProcNoRepo . runGitInDir

67gitProc repo = gitProcNoRepo . runGitInDir

69 where

68 where

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

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

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

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

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

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

73+isolateGitProc :: ProcessSpec -> ProcessSpec

74+isolateGitProc = setEnvOverride (overrides <>)

75+ where

76+ overrides = M.fromList

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

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

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

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

81+ ]

82+

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

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

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

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

76copyDir src dest =

85copyDir src dest =

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

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

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

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

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

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

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

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

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

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

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

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

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

91runProc = callProcessAndLogOutput (Notice, Error)

100runProc = callProcessAndLogOutput (Notice, Error)

101

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

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

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

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

95runProcSilently = callProcessAndLogOutput (Debug, Debug)

104runProcSilently = callProcessAndLogOutput (Debug, Debug)

105

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

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

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

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

99readProc = readProcessAndLogOutput (Debug, Error)

108readProc = readProcessAndLogOutput (Debug, Error)

100

109

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

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

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

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

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

130 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

139 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

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

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

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

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

133− Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo $

142+ Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo

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

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

135 let t = T.pack out

144 let t = T.pack out

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

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

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

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

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

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

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

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

140 pure (exitCode, maps)

149 pure (exitCode, maps)

141

150

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

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

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

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

20import qualified System.Info

21−import System.Process (proc)

23import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

22import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

24import Obelisk.CliApp

23import Obelisk.CliApp

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

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

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

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

131 -- Providing TLS here will also incidentally provide it to proxied requests to the backend.

132− prepareRunner = case (uri ^? uriScheme . _Just . unRText) of

132+ prepareRunner = case uri ^? uriScheme . _Just . unRText of

133 Just "https" -> do

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

135 privateKey <- RSA.generateRSAKey' 2048 3

lib/selftest/src/Obelisk/SelfTest.hs+38−22

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

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE ViewPatterns #-}

6module Obelisk.SelfTest where

7module Obelisk.SelfTest where

8import Control.Exception (bracket, throw)

9import Control.Exception (bracket, throw)

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

24import System.Directory (withCurrentDirectory, getDirectoryContents)

25import System.Directory (withCurrentDirectory, getDirectoryContents)

25import System.Environment

26import System.Environment

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

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

27−import System.Info

28+import qualified System.Info

28import System.IO (Handle, hClose)

29import System.IO (Handle, hClose)

29import System.IO.Temp

30import System.IO.Temp

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

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

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

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

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

76 let verbosity = bool silently verbosely isVerbose

77 let verbosity = bool silently verbosely isVerbose

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

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

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

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

80+ let

81+ withObeliskImpl f =

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

83+ void . shellyOb verbosity $ chdir obeliskImpl $ do

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

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

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

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

88+

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

90+ -- Setup the ob init cache

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

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

93+ run_ "git" ["init"]

94+

95+ f obeliskImpl initCache

96+

79 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

97 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

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

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

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

99+

82− -- Setup the ob init cache

100+ withObeliskImpl $ \obeliskImpl initCache ->

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

84− run_ "ob" ["init"]

85− run_ "git" ["init"]

86 hspec $ parallel $ do

101 hspec $ parallel $ do

87 let shelly_ = void . shellyOb verbosity

102 let shelly_ = void . shellyOb verbosity

103

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

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

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

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

106

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

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

108

94 inTmpObInit f = inTmp $ \dir -> do

109 inTmpObInit f = inTmp $ \dir -> do

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

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

96 f dir

111 f dir

112

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

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

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

115 describe "ob init" $ parallel $ do

130 describe "ob init" $ parallel $ do

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

140

155

141 describe "obelisk project" $ parallel $ do

156 describe "obelisk project" $ parallel $ do

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

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

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

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

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

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

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

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

146

161

147 describe "blank initialized project" $ parallel $ do

162 describe "blank initialized project" $ parallel $ do

148

163

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

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

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

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

151

166

152− if os == "darwin"

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

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

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

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

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

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

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

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

162

177

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

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

164 let

179 let

165− shell = "shells." <> compiler

180+ shellName = "shells." <> compiler

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

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

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

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

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

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

169

184

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

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

186+ _ <- pack

171 u <- update

187 u <- update

172 uu <- update

188 uu <- update

173 assertRevEQ u uu

189 assertRevEQ u uu

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

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

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

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

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

177

193

194+ _ <- pack

178 e <- commitAll

195 e <- commitAll

179 eu <- unpack

196 eu <- unpack

180 eup <- pack

197 eup <- pack

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

212 testThunkPack $ fromText repo

229 testThunkPack $ fromText repo

213

230

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

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

215− void unpack

216 testThunkPack (dir </> thunk)

232 testThunkPack (dir </> thunk)

217

233

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

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

skeleton/.gitignore+1

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

1dist-newstyle

2result

3+result-*

3result-android

4result-android

4result-ios

5result-ios

5result-exe

6result-exe

skeleton/common/common.cabal−3

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

9 , obelisk-route

10 , mtl

11 , text

12− default-extensions:

13− TypeFamilies

14− PolyKinds

15 exposed-modules:

12 exposed-modules:

16 Common.Api

13 Common.Api

17 Common.Route

14 Common.Route

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

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

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeFamilies #-}

11module Common.Route where

12module Common.Route where

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

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

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

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

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE TypeApplications #-}

4module Frontend where

5module Frontend where

6import qualified Data.Text as T

7import qualified Data.Text as T

7import qualified Data.Text.Encoding as T

8import qualified Data.Text.Encoding as T

8import Obelisk.Frontend

10import Obelisk.Frontend

9import Obelisk.Configs

11import Obelisk.Configs

10import Obelisk.Route

12import Obelisk.Route

13+import Obelisk.Generated.Static

14+

11import Reflex.Dom.Core

15import Reflex.Dom.Core

13import Common.Api

17import Common.Api

14import Common.Route

18import Common.Route

15−import Obelisk.Generated.Static

19+

17frontend :: Frontend (R FrontendRoute)

21frontend :: Frontend (R FrontendRoute)

18frontend = Frontend

22frontend = Frontend

23+ { _frontend_head = do

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

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

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

20 , _frontend_body = do

26 , _frontend_body = do

21− text "Welcome to Obelisk!"

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

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

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

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

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

24 el "div" $ do

30 el "div" $ do

skeleton/static/main.cssnew file+3

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

1+p {

2+ color: red;

3+}