@@ -4,17 +4,20 @@
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5module Obelisk.Command.Deploy where
5module Obelisk.Command.Deploy where
7+import Control.Applicative
7import Control.Monad
8import Control.Monad
8import Control.Monad.Catch (finally)
9import Control.Monad.Catch (finally)
9import Control.Monad.IO.Class (liftIO)
10import Control.Monad.IO.Class (liftIO)
11+import Data.Attoparsec.ByteString.Char8 as A
12+import qualified Data.ByteString.Char8 as BC8
10import Data.Default
13import Data.Default
11import Data.Maybe
14import Data.Maybe
12import Data.Monoid
15import Data.Monoid
13import qualified Data.Text as T
16import qualified Data.Text as T
14import qualified Data.Text.IO as T
17import qualified Data.Text.IO as T
15import System.Directory
18import System.Directory
19+import System.Exit (ExitCode (..))
16import System.FilePath
20import System.FilePath
17−import System.Posix.Files
18import System.Process
21import System.Process
20import Obelisk.App (MonadObelisk)
23import Obelisk.App (MonadObelisk)
@@ -36,18 +39,19 @@ deployInit thunkPtr configDir deployDir sshKeyPath hostnames = do
36 , configDir
39 , configDir
37 , deployDir </> "config"
40 , deployDir </> "config"
42+ keyExists <- liftIO $ doesFileExist sshKeyPath
44+ let localKey = deployDir </> "ssh_key"
45+ callProcessAndLogOutput (Notice, Error) $
46+ cp [sshKeyPath, localKey]
47+ liftIO $ setPermissions localKey $ setOwnerWritable True $ setOwnerReadable True emptyPermissions
39 liftIO $ do
48 liftIO $ do
40− keyExists <- doesFileExist sshKeyPath
42− target <- makeAbsolute sshKeyPath
43− createSymbolicLink target (deployDir </> "ssh_key")
44 createThunk (deployDir </> "src") thunkPtr
49 createThunk (deployDir </> "src") thunkPtr
45 writeFile (deployDir </> "backend_hosts") $ unlines hostnames
50 writeFile (deployDir </> "backend_hosts") $ unlines hostnames
46 initGit deployDir
51 initGit deployDir
48deployPush :: MonadObelisk m => FilePath -> m ()
53deployPush :: MonadObelisk m => FilePath -> m ()
49deployPush deployPath = do
54deployPush deployPath = do
50− liftIO $ callProcess "ssh-add" [deployPath </> "ssh_key"]
51 host <- liftIO $ fmap (T.unpack . T.strip) $ T.readFile $ deployPath </> "backend_hosts"
55 host <- liftIO $ fmap (T.unpack . T.strip) $ T.readFile $ deployPath </> "backend_hosts"
52 let srcPath = deployPath </> "src"
56 let srcPath = deployPath </> "src"
53 build = do
57 build = do
@@ -61,9 +65,8 @@ deployPush deployPath = do
62 return $ listToMaybe $ lines buildOutput
66 return $ listToMaybe $ lines buildOutput
63 result <- readThunk srcPath >>= \case
67 result <- readThunk srcPath >>= \case
64− Right (ThunkData_Packed _) -> do
68+ Right (ThunkData_Packed _) ->
65− unpackThunk srcPath
69+ build
66− build `finally` packThunk srcPath "origin" -- get upstream
67 Right (ThunkData_Checkout _) -> do
70 Right (ThunkData_Checkout _) -> do
68 liftIO (checkGitCleanStatus srcPath) >>= \case
71 liftIO (checkGitCleanStatus srcPath) >>= \case
69 True -> do
72 True -> do
@@ -75,19 +78,42 @@ deployPush deployPath = do
75 return Nothing
78 return Nothing
76 _ -> return Nothing
79 _ -> return Nothing
77 liftIO $ forM_ result $ \res -> do
80 liftIO $ forM_ result $ \res -> do
81+ let deployAndSwitch outputPath sshAgentEnv = do
82+ callProcess' (Just sshAgentEnv) "ssh-add" [deployPath </> "ssh_key"]
78− callProcess "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", res]
83+ callProcess' (Just sshAgentEnv) "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
79− callProcess "ssh"
84+ callProcess' (Just sshAgentEnv) "ssh"
80− [ "root@" <> host
85+ [ "root@" <> host
81− , unwords
86+ , unwords
82− [ "nix-env -p /nix/var/nix/profiles/system --set " <> res
87+ [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
84− , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
89+ , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
92+ sshAgentEnv <- sshAgent
93+ deployAndSwitch res sshAgentEnv `finally` callProcess' (Just sshAgentEnv) "ssh-agent" ["-k"]
87− isClean <- liftIO $ checkGitCleanStatus deployPath
94+ isClean <- checkGitCleanStatus deployPath
88− when (not isClean) $ liftIO $ do
95+ when (not isClean) $ do
89 callProcess "git" ["-C", deployPath, "add", "--update"]
96 callProcess "git" ["-C", deployPath, "add", "--update"]
90 callProcess "git" ["-C", deployPath, "commit", "-m", "New deployment"]
97 callProcess "git" ["-C", deployPath, "commit", "-m", "New deployment"]
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
103+ ExitSuccess -> return ()
104+ ExitFailure r -> fail $ "callProcess'" <> "(exit: " <> show r <> ")"
92deployUpdate :: MonadObelisk m => FilePath -> m ()
106deployUpdate :: MonadObelisk m => FilePath -> m ()
93deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"
107deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"
109+sshAgent :: IO [(String, String)]
111+ output <- BC8.pack <$> readProcess "ssh-agent" ["-c"] mempty
112+ return $ fromMaybe mempty $ A.maybeResult $ A.parse (A.many' p) output
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)