491fc94 · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge pull request #84 from obsidiansystems/eac-wrapProgram

Use wrapProgram make ob supply its own runtime deps

commit491fc9475b84232bc1e71413adb470cb5a48f321 authorRyan Trinkle <ryan.trinkle@gmail.com> dateThu 21 Jun 2018, 11:31 (8 years ago) parent3441cd6 756a820

6 files changed+58−68

compare with master

unifiedsplit

default.nix+17−7 lib/command/src/Obelisk/Command/Deploy.hs+7−9 lib/command/src/Obelisk/Command/Project.hs+2−3 lib/command/src/Obelisk/Command/Thunk.hs+20−24 lib/command/src/Obelisk/Command/Utils.hs+12−24 lib/command/src/Obelisk/Command/VmBuilder.hs−1

default.nix+17−7

@@ -16,6 +16,15 @@ let

1616 then removeConfigureFlag drv' "--ghc-option=-optl=-dead_strip"

1717 else drv';

1818

19+ commandRuntimeDeps = pkgs: with pkgs; [

20+ coreutils

21+ git

22+ gitAndTools.hub

23+ nix-prefetch-git

24+ nixStable

25+ openssh

26+ ];

27+

1928 #TODO: Upstream

2029 # Modify a Haskell package to add completion scripts for the given

2130 # executable produced by it. These completion scripts will be picked up

@@ -114,18 +123,19 @@ rec {

114123 inherit (reflex-platform) nixpkgs pinBuildInputs;

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

116125 obelisk = ghcObelisk;

117− command = ghcObelisk.obelisk-command;

118− shell = pinBuildInputs "obelisk-shell" ([

119− command

120− pkgs.openssh

121− pkgs.gitAndTools.hub

122− ]) [];

126+ command = pkgs.runCommand "ob" { nativeBuildInputs = [pkgs.makeWrapper]; } ''

127+ mkdir -p "$out/bin"

128+ ln -s '${ghcObelisk.obelisk-command}/bin/ob' "$out/bin/ob"

129+ wrapProgram "$out"/bin/ob --prefix PATH : ${pkgs.lib.makeBinPath (commandRuntimeDeps pkgs)}

130+ '';

131+ commandEnv = ghcObelisk.obelisk-command.env;

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

123133

124134 selftest = pkgs.writeScript "selftest" ''

125135 #!/usr/bin/env bash

126136 set -euo pipefail

127137

128− PATH="${ghcObelisk.obelisk-command}/bin:$PATH"

138+ PATH="${command}/bin:$PATH"

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

130140 "${justStaticExecutables' ghcObelisk.obelisk-selftest}/bin/obelisk-selftest" "$@"

131141 '';

lib/command/src/Obelisk/Command/Deploy.hs+7−9

@@ -34,21 +34,19 @@ deployInit thunkPtr configDir deployDir sshKeyPath hostnames = do

3434 localKey <- liftIO (doesFileExist sshKeyPath) >>= \case

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

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

37− callProcessAndLogOutput (Notice, Error) $

38− cp [sshKeyPath, localKey]

37+ callProcessAndLogOutput (Notice, Error) $ proc "cp" [sshKeyPath, localKey]

3938 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode

4039 liftIO $ writeFile (deployDir </> "backend_hosts") $ unlines hostnames

4140 forM_ hostnames $ \hostname -> do

4241 putLog Notice $ "Verifying host keys (" <> T.pack hostname <> ")"

4342 verifyHostKey (deployDir </> "backend_known_hosts") localKey hostname

4443 when hasConfigDir $ do

45− callProcessAndLogOutput (Notice, Error) $

46− cp

47− [ "-r"

48− , "-T"

49− , configDir

50− , deployDir </> "config"

51− ]

44+ callProcessAndLogOutput (Notice, Error) $ proc "cp"

45+ [ "-r"

46+ , "-T"

47+ , configDir

48+ , deployDir </> "config"

49+ ]

5250 liftIO $ createThunk (deployDir </> "src") thunkPtr

5351 liftIO $ setupObeliskImpl deployDir

5452 initGit deployDir

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

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

3535import Obelisk.App (MonadObelisk)

3636import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, createProcess_, failWith, putLog, withSpinner)

3737import Obelisk.Command.Thunk

38−import Obelisk.Command.Utils (cp)

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

4039

4140--TODO: Don't hardcode this

@@ -86,7 +85,7 @@ initProject source = withSystemTempDirectory "ob-init" $ \tmpDir -> do

8685 skel <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this

8786

8887 callProcessAndLogOutput (Notice, Error) $

89− cp

88+ proc "cp"

9089 [ "-r"

9190 , "--preserve=links"

9291 , obDir

@@ -96,7 +95,7 @@ initProject source = withSystemTempDirectory "ob-init" $ \tmpDir -> do

9695

9796 withSpinner "Copying project skeleton" $ do

9897 callProcessAndLogOutput (Notice, Error) $

99− cp --TODO: Make this package depend on nix-prefetch-url properly

98+ proc "cp"

10099 [ "-r"

101100 , "--no-preserve=mode"

102101 , "-T"

lib/command/src/Obelisk/Command/Thunk.hs+20−24

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

77{-# LANGUAGE PatternGuards #-}

88{-# LANGUAGE ScopedTypeVariables #-}

99{-# LANGUAGE TypeApplications #-}

10−

1110module Obelisk.Command.Thunk

1211 ( ThunkPtr (..)

1312 , ThunkRev (..)

@@ -74,7 +73,7 @@ import System.Process (proc)

7473import Obelisk.App (MonadObelisk)

7574import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, failWith, putLog, readProcessAndLogStderr,

7675 withExitFailMessage, withSpinner)

77−import Obelisk.Command.Utils (checkGitCleanStatus, cp, git, procWithPackages)

76+import Obelisk.Command.Utils (checkGitCleanStatus, gitProc)

7877

7978--TODO: Support symlinked thunk data

8079data ThunkData

@@ -131,7 +130,7 @@ getNixSha256ForUriUnpacked :: MonadObelisk m => URI -> m NixSha256

131130getNixSha256ForUriUnpacked uri =

132131 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> T.pack (show uri)) $ do

133132 fmap T.pack $ readProcessAndLogStderr Debug $

134− procWithPackages ["nix-prefetch-scripts"] "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]

133+ proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]

135134

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

137136nixPrefetchGit uri rev fetchSubmodules =

@@ -151,10 +150,10 @@ nixPrefetchGit uri rev fetchSubmodules =

151150getLatestGitRev :: MonadObelisk m => GitSource -> m ThunkRev

152151getLatestGitRev s = withSystemTempDirectory "git-clone" $ \tmpDir -> do

153152 withExitFailMessage ("Unable to determine latest git revision for branch " <> branch) $ do

154− out <- fmap T.pack $ readProcessAndLogStderr Debug $ git tmpDir

155− [ ["clone", "--no-checkout", show $ _gitSource_url s] -- Might be able to use --bare here instead to go faster.

156− , ["log", T.unpack branch, "--max-count=1", "--format=%H"]

157− ]

153+ let git = fmap T.pack . readProcessAndLogStderr Debug . gitProc tmpDir

154+ out <- liftA2 (<>)

155+ (git ["clone", "--no-checkout", show $ _gitSource_url s]) -- Might be able to use --bare here instead to go faster.

156+ (git ["log", T.unpack branch, "--max-count=1", "--format=%H"])

158157

159158 case T.strip <$> safeLast (T.lines out) of

160159 Nothing -> failWith $ "Unable to parse git log: " <> out

@@ -599,7 +598,7 @@ unpackThunk thunkDir = readThunk thunkDir >>= \case

599598 --If this directory already exists then something is weird and we should fail

600599 liftIO $ createDirectory obGitDir

601600 callProcessAndLogOutput (Notice, Error) $

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

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

603602

604603 withSpinner ("Preparing thunk in " <> T.pack thunkDir) $ do

605604 -- Checkout

@@ -615,28 +614,26 @@ unpackThunk thunkDir = readThunk thunkDir >>= \case

615614 forM_ (_gitHubSource_branch s) $ \branch ->

616615 callProcessAndLogOutput (Notice, Error) $

617616 proc "hub" ["-C", tmpRepo, "branch", "-u", "origin/" <> T.unpack (untagName branch)]

618− callProcessAndLogOutput (Notice, Error) $

619− proc "rm" ["-r", thunkDir]

620− callProcessAndLogOutput (Notice, Error) $

621− procWithPackages ["coreutils"] "mv" ["-T", tmpRepo, thunkDir]

617+ callProcessAndLogOutput (Notice, Error) $ proc "rm" ["-r", thunkDir]

618+ callProcessAndLogOutput (Notice, Error) $ proc "mv" ["-T", tmpRepo, thunkDir]

622619

623620 ThunkSource_Git s -> do

624− withSpinner ("Retreiving thunk " <> T.pack thunkName <> " from Git repo") $

625− callProcessAndLogOutput (Notice, Notice) $ git tmpRepo

626− [ ["clone", if _gitSource_fetchSubmodules s then "--recursive" else "", show (_gitSource_url s)]

627− , ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

628− , if _gitSource_fetchSubmodules s then ["submodule", "update", "--recursive"] else []

629− , ["branch", "-u", "origin/" <> T.unpack (untagName $ _gitSource_branch s)]

630− ]

621+ withSpinner ("Retreiving thunk " <> T.pack thunkName <> " from Git repo") $ do

622+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo

623+ git ["clone", if _gitSource_fetchSubmodules s then "--recursive" else "", show (_gitSource_url s)]

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

625+ when (_gitSource_fetchSubmodules s) $

626+ git ["submodule", "update", "--recursive", "--init"]

627+ git ["branch", "-u", "origin/" <> T.unpack (untagName $ _gitSource_branch s)]

631628

632629 withSpinner ("Preparing thunk in " <> T.pack thunkDir) $ do

633630 liftIO $ createDirectory obGitDir

634631 callProcessAndLogOutput (Notice, Error) $

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

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

636633 callProcessAndLogOutput (Notice, Error) $

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

638635 callProcessAndLogOutput (Notice, Error) $

639− procWithPackages ["coreutils"] "mv" ["-T", tmpRepo, thunkDir]

636+ proc "mv" ["-T", tmpRepo, thunkDir]

640637

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

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

@@ -661,8 +658,7 @@ getThunkPtr' :: MonadObelisk m => Bool -> FilePath -> Text -> m ThunkPtr

661658getThunkPtr' checkClean thunkDir upstream = do

662659 when checkClean $ checkGitCleanStatus thunkDir >>= \case

663660 False -> do

664− statusDebug <- fmap T.pack $ readProcessAndLogStderr Notice $

665− git thunkDir [["status", "--ignored"]]

661+ statusDebug <- readGitProcess thunkDir ["status", "--ignored"]

666662 putLog Warning "cannot proceed with unsaved working copy (git status):"

667663 putLog Notice statusDebug

668664 failWith "thunk pack: thunk checkout contains unsaved modifications"

@@ -795,4 +791,4 @@ parseSshShorthand uri = do

795791

796792

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

798−readGitProcess repo args = fmap T.pack $ readProcessAndLogStderr Notice $ git repo [args]

794+readGitProcess repo = fmap T.pack . readProcessAndLogStderr Notice . gitProc repo

lib/command/src/Obelisk/Command/Utils.hs+12−24

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

22{-# LANGUAGE OverloadedStrings #-}

33module Obelisk.Command.Utils where

5−import qualified Data.List as L

5+import Control.Applicative (liftA2)

66import Data.Semigroup ((<>))

77import qualified Data.Text as T

88import qualified System.Process as P

@@ -13,36 +13,24 @@ import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, readProcessAndLog

1313-- Check whether the working directory is clean

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

1515checkGitCleanStatus repo = do

16− out <- readProcessAndLogStderr Debug $ git repo [["status", "--porcelain", "--ignored"], ["diff"]]

17− pure $ null out

16+ let git = readProcessAndLogStderr Debug . gitProc repo

17+ null <$> liftA2 (<>) (git ["status", "--porcelain", "--ignored"]) (git ["diff"])

1818

1919initGit :: MonadObelisk m => FilePath -> m ()

20−initGit dir = callProcessAndLogOutput (Debug, Debug) $ git dir

21− [ ["init"]

22− , ["add", "."]

23− , ["commit", "-m", "Initial commit."]

24− ]

25−

26−git :: FilePath -> [[String]] -> P.CreateProcess

27−git repo argss =

28− inNixShell ["git"] $ L.intercalate "; " $

29− map (processToShellString "git" . runGitInDir) $ filter (not . null) argss

20+initGit repo = do

21+ let git = callProcessAndLogOutput (Debug, Debug) . gitProc repo

22+ git ["init"]

23+ git ["add", "."]

24+ git ["commit", "-m", "Initial commit."]

25+

26+gitProc :: FilePath -> [String] -> P.CreateProcess

27+gitProc repo argsRaw =

28+ P.proc "git" $ runGitInDir argsRaw

3029 where

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

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

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

3433

35−-- | Like `System.Process.proc` but with the specified Nix packages installed

36−procWithPackages :: [String] -> FilePath -> [String] -> P.CreateProcess

37−procWithPackages pkgs cmd args = inNixShell pkgs $ processToShellString cmd args

38−

39−inNixShell :: [String] -> String -> P.CreateProcess

40−inNixShell pkgs cmd = P.proc "nix-shell" $ "-p" : pkgs <> ["--run", cmd]

41−

4234processToShellString :: FilePath -> [String] -> String

4335processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

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

45−

46−-- | Portable `cp` command.

47−cp :: [String] -> P.CreateProcess

48−cp = procWithPackages ["coreutils"] "cp"

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

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

11{-# LANGUAGE FlexibleContexts #-}

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE QuasiQuotes #-}

4−

54module Obelisk.Command.VmBuilder where

76import Control.Applicative (liftA2)