5e8fcce · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge remote-tracking branch 'origin/master' into sr-spinner

5e8fcceSridhar Ratnakumar8 years ago

.gitignore+2

compare with master

unifiedsplit

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

2**/.cabal-sandbox

3**/cabal.sandbox.config

4result

5+*.o

6+*.hi

6*.hi

8*.hi

7*.o

9*.o

lib/command/obelisk-command.cabal+1

@@ -42,6 +42,7 @@ library

42 Obelisk.Command.Repl

43 Obelisk.Command.Run

44 Obelisk.Command.Thunk

45+ Obelisk.Command.Utils

45 -- -fobject-code is so that the StaticPointers extension can work in ghci

46 -- -fobject-code is so that the StaticPointers extension can work in ghci

46 ghc-options: -Wall -fobject-code

47 ghc-options: -Wall -fobject-code

lib/command/src/Obelisk/Command.hs+33−8

@@ -20,10 +20,12 @@ import System.Posix.Process (executeFile)

21import Obelisk.Command.CLI (putErrorAndExit, putWarning, runCLI)

22import Obelisk.Command.Deploy

23+import Obelisk.Command.Deploy

23import Obelisk.Command.Project

24import Obelisk.Command.Project

24import Obelisk.Command.Repl

25import Obelisk.Command.Repl

25import Obelisk.Command.Run

26import Obelisk.Command.Run

26import Obelisk.Command.Thunk

27import Obelisk.Command.Thunk

28+import Obelisk.Command.Utils

28data Args = Args

30data Args = Args

29 { _args_noHandOffPassed :: Bool

31 { _args_noHandOffPassed :: Bool

@@ -95,18 +97,28 @@ obCommand = hsubparser

95 ])

97 ])

97deployCommand :: Parser DeployCommand

99deployCommand :: Parser DeployCommand

98−deployCommand = subparser $ mconcat

100+deployCommand = hsubparser $ mconcat

99 [ command "init" $ info deployInitCommand $ progDesc "Initialize a deployment configuration directory"

101 [ command "init" $ info deployInitCommand $ progDesc "Initialize a deployment configuration directory"

102+ , command "push" $ info (pure DeployCommand_Push) mempty

100 ]

103 ]

101

104

102deployInitCommand :: Parser DeployCommand

105deployInitCommand :: Parser DeployCommand

103−deployInitCommand = DeployCommand_Init

106+deployInitCommand = fmap DeployCommand_Init $ DeployInitOpts

104− <$> strArgument (action "deploy-dir" <> metavar "DEPLOYDIR")

107+ <$> strArgument (action "deploy-dir" <> metavar "DEPLOYDIR" <> help "Path to a directory that it will create")

105− <*> strArgument (action "ssh-key" <> metavar "SSH_KEY")

108+ <*> strOption (long "ssh-key" <> metavar "SSHKEY" <> help "Path to an ssh key that it will symlink to")

106− <*> strArgument (action "hostname" <> metavar "HOSTNAME")

109+ <*> some (strOption (long "hostname" <> metavar "HOSTNAME" <> help "hostname of the deployment target"))

110+ <*> strOption (long "remote" <> metavar "REMOTE" <> help "git remote to use for the src thunk")

107

111

108data DeployCommand

112data DeployCommand

109− = DeployCommand_Init String String String

113+ = DeployCommand_Init DeployInitOpts

114+ | DeployCommand_Push

115+

116+data DeployInitOpts = DeployInitOpts

117+ { _deployInitOpts_ouputDir :: FilePath

118+ , _deployInitOpts_sshKey :: FilePath

119+ , _deployInitOpts_hostname :: [String]

120+ , _deployInitOpts_remote :: String

121+ }

110

122

111internalCommand :: Parser ObInternal

123internalCommand :: Parser ObInternal

112internalCommand = subparser $ mconcat

124internalCommand = subparser $ mconcat

@@ -183,8 +195,21 @@ ob :: ObCommand -> IO ()

183ob = \case

195ob = \case

184 ObCommand_Init source -> initProject source

196 ObCommand_Init source -> initProject source

185 ObCommand_Deploy dc -> case dc of

197 ObCommand_Deploy dc -> case dc of

186− DeployCommand_Init deployDir sshKeyPath hostname -> withProjectRoot "." $ \root ->

198+ DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do

199+ thunkPtr <- readThunk root >>= \case

200+ Left err -> fail $ "thunk pack: " <> show err

201+ Right (ThunkData_Packed ptr) -> return ptr

202+ Right (ThunkData_Checkout (Just ptr)) -> return ptr

203+ Right (ThunkData_Checkout Nothing) ->

204+ getThunkPtr root (_deployInitOpts_remote deployOpts)

205+ let deployDir = _deployInitOpts_ouputDir deployOpts

206+ sshKeyPath = _deployInitOpts_sshKey deployOpts

207+ hostname = _deployInitOpts_hostname deployOpts

187− deployInit (root </> "config") deployDir sshKeyPath hostname

208+ deployInit thunkPtr (root </> "config") deployDir sshKeyPath hostname

209+ DeployCommand_Push -> do

210+ checkGitCleanStatus "." >>= \case

211+ True -> return ()

212+ False -> fail "ob push: Commit any changes to the deployment configuration before proceeding"

188 ObCommand_Run -> inNixShell' $ static run

213 ObCommand_Run -> inNixShell' $ static run

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

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

190 ObCommand_Thunk tc -> case tc of

215 ObCommand_Thunk tc -> case tc of

lib/command/src/Obelisk/Command/Deploy.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Obelisk.Command.Deploy where

4+import Control.Monad

5+import System.Directory

6+import System.FilePath

7+import System.Posix.Files

8+import System.Process

10+import Obelisk.Command.Utils

11+import Obelisk.Command.Thunk

12+

13+deployInit :: ThunkPtr -> FilePath -> FilePath -> FilePath -> [String] -> IO ()

14+deployInit thunkPtr configDir deployDir sshKeyPath hostnames = do

15+ createDirectoryIfMissing True deployDir

16+ hasConfigDir <- doesDirectoryExist configDir

17+ when hasConfigDir $ do

18+ callProcess "cp"

19+ [ "-r"

20+ , "-T"

21+ , configDir

22+ , deployDir </> "config"

23+ ]

24+ keyExists <- doesFileExist sshKeyPath

25+ when keyExists $ do

26+ target <- makeAbsolute sshKeyPath

27+ createSymbolicLink target (deployDir </> "ssh_key")

28+ createThunk (deployDir </> "src") thunkPtr

29+ writeFile (deployDir </> "backend_hosts") $ unlines hostnames

30+ initGit deployDir

31+

lib/command/src/Obelisk/Command/Project.hs−7

@@ -79,13 +79,6 @@ initProject source = do

79 let configDir = "config"

80 createDirectory configDir

81 mapM_ (createDirectory . (configDir </>)) ["backend", "common", "frontend"]

82− initGit

83−

84−initGit :: IO ()

85−initGit = do

86− callProcess "git" ["init"]

87− callProcess "git" ["add", "."]

88− callProcess "git" ["commit", "-m", "Initial commit."]

90--TODO: Handle errors

83--TODO: Handle errors

91--TODO: Allow the user to ignore our security concerns

84--TODO: Allow the user to ignore our security concerns

lib/command/src/Obelisk/Command/Thunk.hs+15−12

@@ -13,12 +13,14 @@ module Obelisk.Command.Thunk

13 , GitHubSource (..)

14 , getLatestRev

15 , updateThunkToLatest

16+ , createThunk

16 , createThunkWithLatest

17 , createThunkWithLatest

17 , nixBuildAttrWithCache

18 , nixBuildAttrWithCache

18 , nixBuildThunkAttrWithCache

19 , nixBuildThunkAttrWithCache

19 , unpackThunk

20 , unpackThunk

20 , packThunk

21 , packThunk

21 , readThunk

22 , readThunk

23+ , getThunkPtr

22 ) where

24 ) where

24import Control.Applicative

26import Control.Applicative

@@ -63,6 +65,7 @@ import System.Process (StdStream (CreatePipe), callProcess, createProcess, proc,

63 std_out, waitForProcess)

65 std_out, waitForProcess)

65import Development.Placeholders

67import Development.Placeholders

68+import Obelisk.Command.Utils

67import Obelisk.Command.CLI (putError, putErrorAndExit, putWarning, withSpinner)

70import Obelisk.Command.CLI (putError, putErrorAndExit, putWarning, withSpinner)

@@ -503,12 +506,17 @@ packThunk thunkDir upstream = readThunk thunkDir >>= \case

503 Left err -> fail $ "thunk pack: " <> show err

506 Left err -> fail $ "thunk pack: " <> show err

504 Right (ThunkData_Packed _) -> putErrorAndExit "pack: thunk is already packed"

507 Right (ThunkData_Packed _) -> putErrorAndExit "pack: thunk is already packed"

505 Right (ThunkData_Checkout _) -> do

508 Right (ThunkData_Checkout _) -> do

506− --Check whether the working directory is clean

509+ thunkPtr <- getThunkPtr thunkDir upstream

507− statusOutput <- readProcess "hub"

510+ callProcess "rm"

511+ [ "-rf"

508− [ "-C", thunkDir

512+ , thunkDir

509− , "status", "--porcelain", "--ignored" ] ""

513+ ]

510− diffOutput <- readProcess "hub" [ "-C", thunkDir , "diff" ] ""

514+ createThunk thunkDir thunkPtr

511− case null statusOutput && null diffOutput of

515+ return ()

516+

517+getThunkPtr :: FilePath -> String -> IO ThunkPtr

518+getThunkPtr thunkDir upstream = do

519+ checkGitCleanStatus thunkDir >>= \case

512 False -> do

520 False -> do

513 statusDebug <- readProcess "hub"

521 statusDebug <- readProcess "hub"

514 [ "-C", thunkDir, "status", "--ignored" ] ""

522 [ "-C", thunkDir, "status", "--ignored" ] ""

@@ -583,12 +591,7 @@ packThunk thunkDir upstream = readThunk thunkDir >>= \case

583 if

591 if

584 | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch

592 | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch

585 | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch

593 | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch

586− callProcess "rm"

594+ return thunkPtr

587− [ "-rf"

588− , thunkDir

589− ]

590− createThunk thunkDir thunkPtr

591− return ()

592 where

595 where

593 refsToTuples [x, y] = (x, y)

596 refsToTuples [x, y] = (x, y)

594 refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x

597 refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x

lib/command/src/Obelisk/Command/Utils.hsnew file+19

@@ -0,0 +1,19 @@

1+module Obelisk.Command.Utils where

3+import System.Process

5+-- Check whether the working directory is clean

6+checkGitCleanStatus :: FilePath -> IO Bool

7+checkGitCleanStatus fp = do

8+ statusOutput <- readProcess "hub"

9+ [ "-C", fp

10+ , "status", "--porcelain", "--ignored" ] ""

11+ diffOutput <- readProcess "hub" [ "-C", fp , "diff" ] ""

12+ return $ null statusOutput && null diffOutput

13+

14+initGit :: FilePath -> IO ()

15+initGit dir = do

16+ let git args = callProcess "git" $ "-C" : dir : args

17+ git ["init"]

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

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