git.iko.soy/obelisk
on 3caa3db help sign in
obelisk/lib/command/src/Obelisk/Command/Deploy.hs
149 lines 5.9 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5module Obelisk.Command.Deploy where
7import Control.Applicative
8import Control.Monad
9import Control.Monad.Catch (finally)
10import Control.Monad.IO.Class (liftIO)
11import Data.Attoparsec.ByteString.Char8 as A
12import qualified Data.ByteString.Char8 as BC8
13import Data.Bits
14import Data.Default
15import Data.Maybe
16import Data.Monoid
17import qualified Data.Text as T
18import qualified Data.Text.IO as T
19import System.Directory
20import System.FilePath
21import System.Posix.Files
22import System.Posix.Env (getEnvironment)
23import System.Process (delegate_ctlc, env, proc, readProcess)
25import Obelisk.App (MonadObelisk)
26import Obelisk.CLI (Severity (..), callProcessAndLogOutput, failWith, withSpinner)
27import Obelisk.CLI.Logging
28import Obelisk.Command.Nix
29import Obelisk.Command.Project
30import Obelisk.Command.Thunk
31import Obelisk.Command.Utils
33deployInit :: MonadObelisk m => ThunkPtr -> FilePath -> FilePath -> FilePath -> [String] -> m ()
34deployInit thunkPtr configDir deployDir sshKeyPath hostnames = do
35 hasConfigDir <- liftIO $ do
36 createDirectoryIfMissing True deployDir
37 doesDirectoryExist configDir
38 when hasConfigDir $ do
39 callProcessAndLogOutput (Notice, Error) $
40 cp
41 [ "-r"
42 , "-T"
43 , configDir
44 , deployDir </> "config"
45 ]
46 keyExists <- liftIO $ doesFileExist sshKeyPath
47 when keyExists $ do
48 let localKey = deployDir </> "ssh_key"
49 callProcessAndLogOutput (Notice, Error) $
50 cp [sshKeyPath, localKey]
51 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode
52 liftIO $ writeFile (deployDir </> "backend_hosts") $ unlines hostnames
53 forM_ hostnames $ \hostname -> do
54 putLog Notice $ "Verifying host keys (" <> T.pack hostname <> ")"
55 verifyHostKey (deployDir </> "backend_known_hosts") localKey hostname
56 liftIO $ createThunk (deployDir </> "src") thunkPtr
57 liftIO $ setupObeliskImpl deployDir
58 initGit deployDir
60setupObeliskImpl :: FilePath -> IO ()
61setupObeliskImpl deployDir = do
62 let implDir = toImplDir deployDir
63 createDirectoryIfMissing True implDir
64 writeFile (implDir </> "default.nix") "(import ../../src {}).obelisk"
66deployPush :: MonadObelisk m => FilePath -> m ()
67deployPush deployPath = do
68 let backendHosts = deployPath </> "backend_hosts"
69 host <- liftIO $ fmap (T.unpack . T.strip) $ T.readFile backendHosts
70 let srcPath = deployPath </> "src"
71 build = do
72 buildOutput <- nixBuild $ def
73 { _nixBuildConfig_target = Target
74 { _target_path = srcPath
75 , _target_attr = Just "server"
76 }
77 , _nixBuildConfig_outLink = OutLink_None
78 , _nixBuildConfig_args = pure $ Arg "hostName" host
79 }
80 return $ listToMaybe $ lines buildOutput
81 result <- readThunk srcPath >>= \case
82 Right (ThunkData_Packed _) ->
83 build
84 Right (ThunkData_Checkout _) -> do
85 checkGitCleanStatus srcPath >>= \case
86 True -> do
87 result <- build
88 packThunk srcPath "origin" -- get upstream
89 return result
90 False -> do
91 _ <- failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
92 return Nothing
93 _ -> return Nothing
94 forM_ result $ \res -> do
95 let knownHostsPath = deployPath </> "backend_known_hosts"
96 sshOpts = ["-o", "UserKnownHostsFile=" <> knownHostsPath, "-o", "StrictHostKeyChecking=yes"]
97 deployAndSwitch outputPath sshAgentEnv = do
98 withSpinner "Adding ssh key" $ do
99 callProcess' sshAgentEnv "ssh-add" [deployPath </> "ssh_key"]
100 withSpinner "Uploading closure" $ do
101 let nixSshEnv = ("NIX_SSHOPTS", unwords sshOpts) : sshAgentEnv
102 callProcess' nixSshEnv "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
103 withSpinner "Switching to new configuration" $ do
104 callProcess' sshAgentEnv "ssh" $ sshOpts <>
105 [ "root@" <> host
106 , unwords
107 [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
108 , "&&"
109 , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
110 ]
111 ]
112 sshAgentEnv <- liftIO sshAgent
113 deployAndSwitch res sshAgentEnv `finally` callProcess' sshAgentEnv "ssh-agent" ["-k"]
114 isClean <- checkGitCleanStatus deployPath
115 when (not isClean) $ do
116 withSpinner "Commiting changes to Git" $ do
117 callProcessAndLogOutput (Debug, Error) $ proc "git"
118 ["-C", deployPath, "add", "."]
119 callProcessAndLogOutput (Debug, Error) $ proc "git"
120 ["-C", deployPath, "commit", "-m", "New deployment"]
121 where
122 callProcess' e cmd args = do
123 currentEnv <- liftIO getEnvironment
124 let p = (proc cmd args) { delegate_ctlc = True, env = Just $ e <> currentEnv }
125 callProcessAndLogOutput (Notice, Notice) p
127deployUpdate :: MonadObelisk m => FilePath -> m ()
128deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"
130sshAgent :: IO [(String, String)]
131sshAgent = do
132 output <- BC8.pack <$> readProcess "ssh-agent" ["-c"] mempty
133 return $ fromMaybe mempty $ A.maybeResult $ A.parse (A.many' p) output
134 where
135 p = do
136 key <- A.string "setenv" >> A.skipSpace >> A.takeWhile (not . isSpace)
137 val <- A.skipSpace >> A.takeWhile (/= ';')
138 _ <- A.string ";" >> A.endOfLine <|> void (A.string ";")
139 return (BC8.unpack key, BC8.unpack val)
141verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
142verifyHostKey knownHostsPath keyPath hostName =
143 callProcessAndLogOutput (Notice, Warning) $ proc "ssh"
144 [ "-o", "UserKnownHostsFile=" <> knownHostsPath
145 , "-o", "StrictHostKeyChecking=ask"
146 , "-i", keyPath
147 , "root@" <> hostName
148 , "exit"
149 ]