@@ -4,17 +4,20 @@
44{-# LANGUAGE ScopedTypeVariables #-}
55module Obelisk.Command.Deploy where
66
7+import Control.Applicative
78import Control.Monad
89import Control.Monad.Catch (finally)
910import Control.Monad.IO.Class (liftIO)
11+import Data.Attoparsec.ByteString.Char8 as A
12+import qualified Data.ByteString.Char8 as BC8
1013import Data.Default
1114import Data.Maybe
1215import Data.Monoid
1316import qualified Data.Text as T
1417import qualified Data.Text.IO as T
1518import System.Directory
19+import System.Exit (ExitCode (..))
1620import System.FilePath
17−import System.Posix.Files
1821import System.Process
1922
2023import Obelisk.App (MonadObelisk)
@@ -36,18 +39,19 @@ deployInit thunkPtr configDir deployDir sshKeyPath hostnames = do
3639 , configDir
3740 , deployDir </> "config"
3841 ]
42+ keyExists <- liftIO $ doesFileExist sshKeyPath
43+ when keyExists $ do
44+ let localKey = deployDir </> "ssh_key"
45+ callProcessAndLogOutput (Notice, Error) $
46+ cp [sshKeyPath, localKey]
47+ liftIO $ setPermissions localKey $ setOwnerWritable True $ setOwnerReadable True emptyPermissions
3948 liftIO $ do
40− keyExists <- doesFileExist sshKeyPath
41− when keyExists $ do
42− target <- makeAbsolute sshKeyPath
43− createSymbolicLink target (deployDir </> "ssh_key")
4449 createThunk (deployDir </> "src") thunkPtr
4550 writeFile (deployDir </> "backend_hosts") $ unlines hostnames
4651 initGit deployDir
4752
4853deployPush :: MonadObelisk m => FilePath -> m ()
4954deployPush deployPath = do
50− liftIO $ callProcess "ssh-add" [deployPath </> "ssh_key"]
5155 host <- liftIO $ fmap (T.unpack . T.strip) $ T.readFile $ deployPath </> "backend_hosts"
5256 let srcPath = deployPath </> "src"
5357 build = do
@@ -61,9 +65,8 @@ deployPush deployPath = do
6165 }
6266 return $ listToMaybe $ lines buildOutput
6367 result <- readThunk srcPath >>= \case
64− Right (ThunkData_Packed _) -> do
65− unpackThunk srcPath
66− build `finally` packThunk srcPath "origin" -- get upstream
68+ Right (ThunkData_Packed _) ->
69+ build
6770 Right (ThunkData_Checkout _) -> do
6871 liftIO (checkGitCleanStatus srcPath) >>= \case
6972 True -> do
@@ -75,19 +78,42 @@ deployPush deployPath = do
7578 return Nothing
7679 _ -> return Nothing
7780 liftIO $ forM_ result $ \res -> do
78− callProcess "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", res]
79− callProcess "ssh"
80− [ "root@" <> host
81− , unwords
82− [ "nix-env -p /nix/var/nix/profiles/system --set " <> res
83− , "&&"
84− , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
85− ]
86− ]
87− isClean <- liftIO $ checkGitCleanStatus deployPath
88− when (not isClean) $ liftIO $ do
81+ let deployAndSwitch outputPath sshAgentEnv = do
82+ callProcess' (Just sshAgentEnv) "ssh-add" [deployPath </> "ssh_key"]
83+ callProcess' (Just sshAgentEnv) "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
84+ callProcess' (Just sshAgentEnv) "ssh"
85+ [ "root@" <> host
86+ , unwords
87+ [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
88+ , "&&"
89+ , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
90+ ]
91+ ]
92+ sshAgentEnv <- sshAgent
93+ deployAndSwitch res sshAgentEnv `finally` callProcess' (Just sshAgentEnv) "ssh-agent" ["-k"]
94+ isClean <- checkGitCleanStatus deployPath
95+ when (not isClean) $ do
8996 callProcess "git" ["-C", deployPath, "add", "--update"]
9097 callProcess "git" ["-C", deployPath, "commit", "-m", "New deployment"]
98+ where
99+ callProcess' e cmd args = do
100+ let p = (proc cmd args) { delegate_ctlc = True, env = e }
101+ exit_code <- withCreateProcess p $ \_ _ _ ph -> waitForProcess ph
102+ case exit_code of
103+ ExitSuccess -> return ()
104+ ExitFailure r -> fail $ "callProcess'" <> "(exit: " <> show r <> ")"
91105
92106deployUpdate :: MonadObelisk m => FilePath -> m ()
93107deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"
108+
109+sshAgent :: IO [(String, String)]
110+sshAgent = do
111+ output <- BC8.pack <$> readProcess "ssh-agent" ["-c"] mempty
112+ return $ fromMaybe mempty $ A.maybeResult $ A.parse (A.many' p) output
113+ where
114+ p = do
115+ key <- A.string "setenv" >> A.skipSpace >> A.takeWhile (not . isSpace)
116+ val <- A.skipSpace >> A.takeWhile (/= ';')
117+ _ <- A.string ";" >> A.endOfLine <|> void (A.string ";")
118+ return (BC8.unpack key, BC8.unpack val)
119+