git.iko.soy/obelisk
on master help sign in
Merge remote-tracking branch 'origin/master' into sr-spinner
commit5e8fcce2f92e690da2e0695fe3ffb2c433887452 authorSridhar Ratnakumar <srid@srid.ca> dateTue 8 May 2018, 19:03 (8 years ago) parent036135d8e26762
7 files changed+101−27
compare with master
unifiedsplit
.gitignore+2 lib/command/obelisk-command.cabal+1 lib/command/src/Obelisk/Command.hs+33−8 lib/command/src/Obelisk/Command/Deploy.hs+31 lib/command/src/Obelisk/Command/Project.hs−7 lib/command/src/Obelisk/Command/Thunk.hs+15−12 lib/command/src/Obelisk/Command/Utils.hs+19
.gitignore+2
@@ -2,6 +2,8 @@
22**/.cabal-sandbox
33**/cabal.sandbox.config
44result
5+*.o
6+*.hi
57
68*.hi
79*.o
lib/command/obelisk-command.cabal+1
@@ -42,6 +42,7 @@ library
4242 Obelisk.Command.Repl
4343 Obelisk.Command.Run
4444 Obelisk.Command.Thunk
45+ Obelisk.Command.Utils
4546 -- -fobject-code is so that the StaticPointers extension can work in ghci
4647 ghc-options: -Wall -fobject-code
4748
lib/command/src/Obelisk/Command.hs+33−8
@@ -20,10 +20,12 @@ import System.Posix.Process (executeFile)
2020
2121import Obelisk.Command.CLI (putErrorAndExit, putWarning, runCLI)
2222import Obelisk.Command.Deploy
23+import Obelisk.Command.Deploy
2324import Obelisk.Command.Project
2425import Obelisk.Command.Repl
2526import Obelisk.Command.Run
2627import Obelisk.Command.Thunk
28+import Obelisk.Command.Utils
2729
2830data Args = Args
2931 { _args_noHandOffPassed :: Bool
@@ -95,18 +97,28 @@ obCommand = hsubparser
9597 ])
9698
9799deployCommand :: Parser DeployCommand
98−deployCommand = subparser $ mconcat
100+deployCommand = hsubparser $ mconcat
99101 [ command "init" $ info deployInitCommand $ progDesc "Initialize a deployment configuration directory"
102+ , command "push" $ info (pure DeployCommand_Push) mempty
100103 ]
101104
102105deployInitCommand :: Parser DeployCommand
103−deployInitCommand = DeployCommand_Init
104− <$> strArgument (action "deploy-dir" <> metavar "DEPLOYDIR")
105− <*> strArgument (action "ssh-key" <> metavar "SSH_KEY")
106− <*> strArgument (action "hostname" <> metavar "HOSTNAME")
106+deployInitCommand = fmap DeployCommand_Init $ DeployInitOpts
107+ <$> strArgument (action "deploy-dir" <> metavar "DEPLOYDIR" <> help "Path to a directory that it will create")
108+ <*> strOption (long "ssh-key" <> metavar "SSHKEY" <> help "Path to an ssh key that it will symlink to")
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")
107111
108112data 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+ }
110122
111123internalCommand :: Parser ObInternal
112124internalCommand = subparser $ mconcat
@@ -183,8 +195,21 @@ ob :: ObCommand -> IO ()
183195ob = \case
184196 ObCommand_Init source -> initProject source
185197 ObCommand_Deploy dc -> case dc of
186− DeployCommand_Init deployDir sshKeyPath hostname -> withProjectRoot "." $ \root ->
187− deployInit (root </> "config") deployDir sshKeyPath hostname
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
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"
188213 ObCommand_Run -> inNixShell' $ static run
189214 -- inNixShell ($(mkClosure 'ghcidAction) ())
190215 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
3+
4+import Control.Monad
5+import System.Directory
6+import System.FilePath
7+import System.Posix.Files
8+import System.Process
9+
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
7979 let configDir = "config"
8080 createDirectory configDir
8181 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."]
8982
9083--TODO: Handle errors
9184--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
1313 , GitHubSource (..)
1414 , getLatestRev
1515 , updateThunkToLatest
16+ , createThunk
1617 , createThunkWithLatest
1718 , nixBuildAttrWithCache
1819 , nixBuildThunkAttrWithCache
1920 , unpackThunk
2021 , packThunk
2122 , readThunk
23+ , getThunkPtr
2224 ) where
2325
2426import Control.Applicative
@@ -63,6 +65,7 @@ import System.Process (StdStream (CreatePipe), callProcess, createProcess, proc,
6365 std_out, waitForProcess)
6466
6567import Development.Placeholders
68+import Obelisk.Command.Utils
6669
6770import Obelisk.Command.CLI (putError, putErrorAndExit, putWarning, withSpinner)
6871
@@ -503,12 +506,17 @@ packThunk thunkDir upstream = readThunk thunkDir >>= \case
503506 Left err -> fail $ "thunk pack: " <> show err
504507 Right (ThunkData_Packed _) -> putErrorAndExit "pack: thunk is already packed"
505508 Right (ThunkData_Checkout _) -> do
506− --Check whether the working directory is clean
507− statusOutput <- readProcess "hub"
508− [ "-C", thunkDir
509− , "status", "--porcelain", "--ignored" ] ""
510− diffOutput <- readProcess "hub" [ "-C", thunkDir , "diff" ] ""
511− case null statusOutput && null diffOutput of
509+ thunkPtr <- getThunkPtr thunkDir upstream
510+ callProcess "rm"
511+ [ "-rf"
512+ , thunkDir
513+ ]
514+ createThunk thunkDir thunkPtr
515+ return ()
516+
517+getThunkPtr :: FilePath -> String -> IO ThunkPtr
518+getThunkPtr thunkDir upstream = do
519+ checkGitCleanStatus thunkDir >>= \case
512520 False -> do
513521 statusDebug <- readProcess "hub"
514522 [ "-C", thunkDir, "status", "--ignored" ] ""
@@ -583,12 +591,7 @@ packThunk thunkDir upstream = readThunk thunkDir >>= \case
583591 if
584592 | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch
585593 | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch
586− callProcess "rm"
587− [ "-rf"
588− , thunkDir
589− ]
590− createThunk thunkDir thunkPtr
591− return ()
594+ return thunkPtr
592595 where
593596 refsToTuples [x, y] = (x, y)
594597 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
2+
3+import System.Process
4+
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."]