79265b5 · obelisk · git.iko.soy

git.iko.soy/obelisk

Add VM builder support using Docker

commit79265b5de57b27f3a08340be550636e4fff8805e author3noch <eacameron@gmail.com> dateMon 28 May 2018, 23:47 (8 years ago) parent65e0464

6 files changed+249−30

compare with master

unifiedsplit

lib/command/obelisk-command.cabal+2 lib/command/src/Obelisk/App.hs+4 lib/command/src/Obelisk/Command.hs+59−26 lib/command/src/Obelisk/Command/Deploy.hs+4−2 lib/command/src/Obelisk/Command/Nix.hs+7−2 lib/command/src/Obelisk/Command/VmBuilder.hs+173

lib/command/obelisk-command.cabal+2

@@ -22,6 +22,7 @@ library

2222 , either

2323 , filepath

2424 , github

25+ , here

2526 , hit

2627 , io-streams

2728 , exceptions

@@ -49,6 +50,7 @@ library

4950 Obelisk.Command.Run

5051 Obelisk.Command.Thunk

5152 Obelisk.Command.Utils

53+ Obelisk.Command.VmBuilder

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

5355 ghc-options: -Wall -fobject-code

5456

lib/command/src/Obelisk/App.hs+4

@@ -10,6 +10,7 @@ module Obelisk.App where

1010import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

1111import Control.Monad.Reader (MonadIO, ReaderT (..), ask, runReaderT)

1212import Control.Monad.Trans.Class (lift)

13+import System.Directory (XdgDirectory (XdgData), getXdgDirectory)

1314

1415import Obelisk.CliApp (Cli, CliConfig, CliT, HasCliConfig, getCliConfig, runCli)

1516

@@ -48,3 +49,6 @@ type MonadObelisk m =

4849 , MonadIO m

4950 , MonadMask m

5051 )

52+

53+getObeliskUserStateDir :: IO FilePath

54+getObeliskUserStateDir = getXdgDirectory XdgData "obelisk"

lib/command/src/Obelisk/Command.hs+59−26

@@ -23,6 +23,7 @@ import Options.Applicative

2323import System.Directory

2424import System.Environment

2525import System.FilePath

26+import qualified System.Info

2627import System.IO (hIsTerminalDevice, stdout)

2728import System.Posix.Process (executeFile)

2829

@@ -31,6 +32,7 @@ import Obelisk.CliApp (Severity (..), failWith, getLogLevel, newCliConfig, putLo

3132import Obelisk.CliApp.Demo (cliDemo)

3233import Obelisk.Command.Deploy

3334import Obelisk.Command.Project

35+import qualified Obelisk.Command.VmBuilder as VmBuilder

3436import Obelisk.Command.Run

3537import Obelisk.Command.Thunk

3638

@@ -45,8 +47,12 @@ data Args = Args

4547 }

4648 deriving Show

4749

48−args :: Parser Args

49−args = Args <$> noHandoff <*> verbose <*> obCommand

50+newtype ArgsConfig = ArgsConfig

51+ { _argsConfig_enableVmBuilderByDefault :: Bool

52+ }

53+

54+args :: ArgsConfig -> Parser Args

55+args cfg = Args <$> noHandoff <*> verbose <*> obCommand cfg

5056

5157noHandoff :: Parser Bool

5258noHandoff = flag False True $ mconcat

@@ -62,8 +68,8 @@ verbose = flag False True $ mconcat

6268 , help "Be more verbose"

6369 ]

6470

65−argsInfo :: ParserInfo Args

66−argsInfo = info (args <**> helper) $ mconcat

71+argsInfo :: ArgsConfig -> ParserInfo Args

72+argsInfo cfg = info (args cfg <**> helper) $ mconcat

6773 [ fullDesc

6874 , progDesc "Manage Obelisk projects"

6975 ]

@@ -95,7 +101,7 @@ inNixShell' p = withProjectRoot "." $ \root -> do

95101 projectShell root False "ghc" cmd

96102 where

97103 mkCmd = do

98− obArgs <- getObArgs

104+ obArgs <- getObArgs =<< getArgsConfig

99105 progName <- getExecutablePath

100106 return $ progName : catMaybes

101107 [ Just "--no-handoff"

@@ -105,11 +111,11 @@ inNixShell' p = withProjectRoot "." $ \root -> do

105111 , Just $ encodeStaticKey $ staticKey p

106112 ]

107113

108−obCommand :: Parser ObCommand

109−obCommand = hsubparser

114+obCommand :: ArgsConfig -> Parser ObCommand

115+obCommand cfg = hsubparser

110116 (mconcat

111117 [ command "init" $ info (ObCommand_Init <$> initSource) $ progDesc "Initialize an Obelisk project"

112− , command "deploy" $ info (ObCommand_Deploy <$> deployCommand) $ progDesc "Prepare a deployment for an Obelisk project"

118+ , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"

113119 , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"

114120 , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"

115121 , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"

@@ -120,10 +126,10 @@ obCommand = hsubparser

120126 , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)

121127 ])

122128

123−deployCommand :: Parser DeployCommand

124−deployCommand = hsubparser $ mconcat

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

126− , command "push" $ info (pure DeployCommand_Push) mempty

129+deployCommand :: ArgsConfig -> Parser DeployCommand

130+deployCommand cfg = hsubparser $ mconcat

131+ [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"

132+ , command "push" $ info (DeployCommand_Push <$> remoteBuilderParser) mempty

127133 , command "test" $ info (DeployCommand_Test <$> platformP) $ progDesc "Test your obelisk project from a mobile platform."

128134 , command "update" $ info (pure DeployCommand_Update) $ progDesc "Update the deployment's src thunk to latest"

129135 ]

@@ -133,8 +139,25 @@ deployCommand = hsubparser $ mconcat

133139 , command "ios" $ info (pure IOS <*> strArgument (metavar "TEAMID" <> help "Your Team ID - found in the Apple developer portal")) mempty

134140 ]

135141

136−deployInitCommand :: Parser DeployCommand

137−deployInitCommand = fmap DeployCommand_Init $ DeployInitOpts

142+ remoteBuilderParser :: Parser (Maybe RemoteBuilder)

143+ remoteBuilderParser =

144+ flag (if enabledByDefault then enabled else Nothing) enabled (mconcat

145+ [ long $ "enable-" <> flagBase

146+ , help $ "Enable " <> flagDesc <> (if enabledByDefault then " (default)" else "")

147+ ])

148+ <|> flag enabled Nothing (mconcat

149+ [ long $ "disable-" <> flagBase

150+ , help $ "Disable a " <> flagDesc <> (if not enabledByDefault then " (default)" else "")

151+ ])

152+ where

153+ enabledByDefault = _argsConfig_enableVmBuilderByDefault cfg

154+ enabled = Just RemoteBuilder_ObeliskVM

155+ flagBase = "vm-builder"

156+ flagDesc = "managed Linux virtual machine and allow builds to use it (requires Docker)"

157+

158+

159+deployInitOpts :: Parser DeployInitOpts

160+deployInitOpts = DeployInitOpts

138161 <$> strArgument (action "directory" <> metavar "DEPLOYDIR" <> help "Path to a directory that it will create")

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

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

@@ -144,9 +167,12 @@ type TeamID = String

144167data PlatformDeployment = Android | IOS TeamID

145168 deriving (Show)

146169

170+data RemoteBuilder = RemoteBuilder_ObeliskVM

171+ deriving (Eq, Show)

172+

147173data DeployCommand

148174 = DeployCommand_Init DeployInitOpts

149− | DeployCommand_Push

175+ | DeployCommand_Push (Maybe RemoteBuilder)

150176 | DeployCommand_Test PlatformDeployment

151177 | DeployCommand_Update

152178 deriving Show

@@ -214,25 +240,27 @@ isInteractiveTerm = do

214240 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs

215241 return $ isTerm && not inShellCompletion

216242

217−mkObeliskConfig :: IO Obelisk

218−mkObeliskConfig = do

243+mkObeliskConfig :: ArgsConfig -> IO Obelisk

244+mkObeliskConfig argsCfg = do

219245 notInteractive <- not <$> isInteractiveTerm

220− logLevel <- toLogLevel <$> getObArgs

246+ logLevel <- toLogLevel <$> getObArgs argsCfg

221247 cliConf <- newCliConfig logLevel notInteractive notInteractive

222248 return $ Obelisk cliConf

223249 where

224250 toLogLevel = bool Notice Debug . _args_verbose

225251

226−getObArgs :: IO Args

227−getObArgs = getArgs >>= handleParseResult . execParserPure parserPrefs argsInfo

252+getObArgs :: ArgsConfig -> IO Args

253+getObArgs cfg = getArgs >>= handleParseResult . execParserPure parserPrefs (argsInfo cfg)

228254

229255main :: IO ()

230−main = mkObeliskConfig >>= (`runObelisk` ObeliskT main')

256+main = do

257+ argsCfg <- getArgsConfig

258+ mkObeliskConfig argsCfg >>= (`runObelisk` ObeliskT (main' argsCfg))

231259

232−main' :: MonadObelisk m => m ()

233−main' = do

260+main' :: MonadObelisk m => ArgsConfig -> m ()

261+main' argsCfg = do

234262 obPath <- liftIO getExecutablePath

235− obArgs <- liftIO getObArgs

263+ obArgs <- liftIO $ getObArgs argsCfg

236264 logLevel <- getLogLevel

237265 putLog Debug $ T.pack $ unwords

238266 [ "Starting Obelisk <" <> obPath <> ">"

@@ -246,7 +274,7 @@ main' = do

246274 --with optparse-applicative until we've done the handoff.

247275 myArgs <- liftIO getArgs

248276 let go as = do

249− args' <- liftIO $ handleParseResult (execParserPure parserPrefs argsInfo as)

277+ args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg) as)

250278 case _args_noHandOffPassed args' of

251279 False -> return ()

252280 True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"

@@ -289,7 +317,9 @@ ob = \case

289317 let sshKeyPath = _deployInitOpts_sshKey deployOpts

290318 hostname = _deployInitOpts_hostname deployOpts

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

292− DeployCommand_Push -> deployPush "."

320+ DeployCommand_Push remoteBuilder -> deployPush "." $ case remoteBuilder of

321+ Nothing -> pure []

322+ Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg

293323 DeployCommand_Update -> deployUpdate "."

294324 DeployCommand_Test Android -> deployMobile "android" []

295325 DeployCommand_Test (IOS teamID) -> deployMobile "ios" [teamID]

@@ -310,6 +340,9 @@ ob = \case

310340

311341--TODO: Clean up all the magic strings throughout this codebase

312342

343+getArgsConfig :: IO ArgsConfig

344+getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" }

345+

313346encodeStaticKey :: StaticKey -> String

314347encodeStaticKey = T.unpack . decodeUtf8 . Base16.encode . LBS.toStrict . Binary.encode

315348

lib/command/src/Obelisk/Command/Deploy.hs+4−2

@@ -62,12 +62,13 @@ setupObeliskImpl deployDir = do

6262 createDirectoryIfMissing True implDir

6363 writeFile (implDir </> "default.nix") "(import ../../src {}).obelisk"

6464

65−deployPush :: MonadObelisk m => FilePath -> m ()

66−deployPush deployPath = do

65+deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()

66+deployPush deployPath getNixBuilders = do

6767 let backendHosts = deployPath </> "backend_hosts"

6868 host <- liftIO $ fmap (T.unpack . T.strip) $ T.readFile backendHosts

6969 let srcPath = deployPath </> "src"

7070 build = do

71+ builders <- getNixBuilders

7172 buildOutput <- nixBuild $ def

7273 { _nixBuildConfig_target = Target

7374 { _target_path = srcPath

@@ -75,6 +76,7 @@ deployPush deployPath = do

7576 }

7677 , _nixBuildConfig_outLink = OutLink_None

7778 , _nixBuildConfig_args = pure $ Arg "hostName" host

79+ , _nixBuildConfig_builders = builders

7880 }

7981 return $ listToMaybe $ lines buildOutput

8082 result <- readThunk srcPath >>= \case

lib/command/src/Obelisk/Command/Nix.hs+7−2

@@ -11,6 +11,7 @@ module Obelisk.Command.Nix

1111 ) where

1212

1313import Data.Default

14+import Data.List (intercalate)

1415import Data.Monoid ((<>))

1516import qualified Data.Text as T

1617import System.Process (proc)

@@ -48,15 +49,16 @@ data NixBuildConfig = NixBuildConfig

4849 { _nixBuildConfig_target :: Target

4950 , _nixBuildConfig_outLink :: OutLink

5051 , _nixBuildConfig_args :: [Arg]

52+ , _nixBuildConfig_builders :: [String]

5153 }

5254

5355instance Default NixBuildConfig where

54− def = NixBuildConfig def def mempty

56+ def = NixBuildConfig def def mempty mempty

5557

5658nixBuild :: MonadObelisk m => NixBuildConfig -> m FilePath

5759nixBuild cfg = withSpinner msg $ do

5860 readProcessAndLogStderr Debug $ proc "nix-build" $ mconcat

59− [[path], attrArg, args, outLink]

61+ [[path], attrArg, args, outLink, buildersArg]

6062 where

6163 path = _target_path $ _nixBuildConfig_target cfg

6264 attr = _target_attr $ _nixBuildConfig_target cfg

@@ -69,3 +71,6 @@ nixBuild cfg = withSpinner msg $ do

6971 OutLink_None -> ["--no-out-link"]

7072 OutLink_IndirectRoot l -> ["--out-link", l]

7173 msg = T.pack $ "Running nix-build on " <> path <> maybe "" (\a -> " [" <> a <> "]") attr

74+ buildersArg = case _nixBuildConfig_builders cfg of

75+ [] -> []

76+ builders -> ["--builders", intercalate ";" builders]

lib/command/src/Obelisk/Command/VmBuilder.hsnew file+173

@@ -0,0 +1,173 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE QuasiQuotes #-}

5+module Obelisk.Command.VmBuilder where

7+import Control.Applicative (liftA2)

8+import Control.Monad (unless)

9+import Control.Monad.Catch (try)

10+import Control.Monad.IO.Class (liftIO)

11+import Data.Either (isRight)

12+import Data.Monoid ((<>))

13+import Data.String (IsString)

14+import Data.String.Here.Uninterpolated (hereLit)

15+import Data.Text (Text)

16+import qualified Data.Text as T

17+import qualified Data.Text.IO as T

18+import System.Directory (createDirectoryIfMissing)

19+import System.Exit (ExitCode)

20+import System.FilePath ((</>), (<.>))

21+import qualified System.Info

22+import System.Process (proc)

23+

24+import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

25+import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, failWith, readProcessAndLogStderr,

26+ withExitFailMessage, withSpinner)

27+

28+-- | Generate the `--builders` argument string to enable the VM builder after ensuring it is available.

29+getNixBuildersArg :: MonadObelisk m => m String

30+getNixBuildersArg = do

31+ stateDir <- liftIO getDockerBuilderStateDir

32+ exists <- containerExists

33+ if exists then startContainer else setupNixDocker stateDir

34+ pure $ nixBuildersArgString stateDir

35+

36+-- | String to pass to nix's `--builders` arguments to enable the VM builder.

37+nixBuildersArgString :: FilePath -> String

38+nixBuildersArgString stateDir = unwords [containerName, "x86_64-linux", stateDir </> sshKeyFileName, "1", "1", "kvm"]

39+

40+-- | Name of Docker container used for the VM builder.

41+containerName :: IsString str => str

42+containerName = "obelisk-docker-nix-builder"

43+

44+-- | Check to see if the Docker container exists. This will exit with a helpful message if Docker is not installed.

45+containerExists :: MonadObelisk m => m Bool

46+containerExists = withExitFailMessage needDockerMsg $ do

47+ containerNames <- fmap (map T.strip . T.lines . T.pack) $

48+ readProcessAndLogStderr Warning $

49+ proc "docker" ["container", "list", "--format", "{{.Names}}"]

50+ pure $ containerName `elem` containerNames

51+ where

52+ needDockerMsg = "This feature requires that you have Docker installed and the `docker` command available on your PATH. Please go https://docs.docker.com/ to install Docker and try this command again."

53+

54+-- | SSH port on localhost that connects to the container.

55+containerSshPort :: Int

56+containerSshPort = 2222

57+

58+-- | Start the Docker container; assumes it already exists.

59+startContainer :: MonadObelisk m => m ()

60+startContainer = callProcessAndLogOutput (Notice, Warning) $

61+ proc "docker" ["start", containerName]

62+

63+-- | Creates the Docker container; assumes it does not exist.

64+setupNixDocker :: MonadObelisk m => FilePath -> m ()

65+setupNixDocker stateDir = withSpinner ("Creating Docker container named " <> containerName) $ do

66+ liftIO $ do

67+ createDirectoryIfMissing True stateDir

68+ T.writeFile (stateDir </> "Dockerfile") dockerfile

69+

70+ -- Create new SSH keys for this container

71+ callProcessAndLogOutput (Notice, Warning) $

72+ proc "rm" ["-f", stateDir </> sshKeyFileName, stateDir </> sshKeyFileName <.> "pub"]

73+ callProcessAndLogOutput (Notice, Warning) $

74+ proc "ssh-keygen" ["-t", "ed25519", "-f", stateDir </> sshKeyFileName, "-P", ""]

75+

76+ -- Build the docker container (which uses the SSH keys in the 'ssh' folder)

77+ containerId <- readProcessAndLogStderr Warning $

78+ proc "docker" ["build", stateDir, "--quiet"]

79+ callProcessAndLogOutput (Notice, Warning) $ proc "docker"

80+ [ "run"

81+ , "--restart", "always"

82+ , "--detach"

83+ , "--publish", show containerSshPort <> ":22"

84+ , "--name", containerName, containerId

85+ ]

86+ exists <- containerExists

87+ unless exists $

88+ failWith $ "Expected to see docker container named " <> containerName <> " but it does not exist."

89+

90+ linuxBuildWorked <- if System.Info.os == "linux"

91+ then pure False -- The Linux test is useless on Linux so just assume the setup is incomplete.

92+ else testLinuxBuild stateDir

93+ unless linuxBuildWorked $ do

94+ let sshIdFile = stateDir </> sshKeyFileName

95+ failWith $ setupInstructions sshIdFile

96+

97+-- | The instructions for setting up SSH access to the container for the Nix daemon.

98+setupInstructions :: FilePath -> Text

99+setupInstructions sshIdFile = T.unlines

100+ [ "Setting Up Docker Nix Builder"

101+ , "-----------------------------"

102+ , ""

103+ , "We've created a Docker container that can build for Linux. However, the Nix"

104+ , "daemon needs to connect to this container as root. Please run the following"

105+ , "commands in a root shell (`sudo su -`) to tell SSH how to access the"

106+ , "container. Then try your obelisk command again."

107+ , ""

108+ , "# sudo su -"

109+ , "touch ~/.ssh/config"

110+ , "cat >> ~/.ssh/config <<CONF"

111+ , ""

112+ , sshConfigHost sshIdFile

113+ , "CONF"

114+ , "ssh " <> containerName <> " nix --version # Answer 'yes' if prompted"

115+ ]

116+

117+-- | SSH configuration for `.ssh/config` to connect to the Docker container.

118+sshConfigHost :: FilePath -> Text

119+sshConfigHost sshIdFile = T.unlines

120+ [ "Host " <> containerName

121+ , " User root"

122+ , " HostName 127.0.0.1"

123+ , " Port " <> T.pack (show containerSshPort)

124+ , " IdentityFile " <> T.pack (show sshIdFile) -- TODO: Check to see how weird paths should be encoded here.

125+ ]

126+

127+-- | User directory where state (namely the SSH keys) is kept for the Docker container.

128+getDockerBuilderStateDir :: IO FilePath

129+getDockerBuilderStateDir = liftA2 (</>) getObeliskUserStateDir (pure "nix-docker-builder")

130+

131+-- | Run a test build to see if a Linux build can finish successfully.

132+testLinuxBuild :: MonadObelisk m => FilePath -> m Bool

133+testLinuxBuild stateDir =

134+ fmap (isRight :: Either ExitCode () -> Bool) $ try $

135+ callProcessAndLogOutput (Debug, Debug) $ proc "nix-build"

136+ [ "-E", "(import <nixpkgs> { system = \"x86_64-linux\"; }).writeText \"test\" builtins.currentTime"

137+ , "--builders", nixBuildersArgString stateDir

138+ ]

139+

140+-- Copied from https://raw.githubusercontent.com/LnL7/nix-docker/bf28b99aebd8e403d2fc2171f4fa8878f857171c/ssh/Dockerfile

141+-- Renamed "insecure_rsa" to 'sshKeyFileName'

142+dockerfile :: Text

143+dockerfile = [hereLit|

144+FROM lnl7/nix:2018-04-17

145+

146+RUN nix-env -f '<nixpkgs>' -iA \

147+ gnused \

148+ openssh \

149+ && nix-store --gc

150+

151+RUN mkdir -p /etc/ssh \

152+ && echo "sshd:x:498:65534::/var/empty:/run/current-system/sw/bin/nologin" >> /etc/passwd \

153+ && cp /root/.nix-profile/etc/ssh/sshd_config /etc/ssh \

154+ && sed -i '/^PermitRootLogin/d' /etc/ssh/sshd_config \

155+ && echo "PermitRootLogin yes" >> /etc/ssh/sshd_config \

156+ && ssh-keygen -f /etc/ssh/ssh_host_rsa_key -N "" -t rsa \

157+ && ssh-keygen -f /etc/ssh/ssh_host_dsa_key -N "" -t dsa \

158+ && echo "export SSL_CERT_FILE=$SSL_CERT_FILE" >> /etc/bashrc \

159+ && echo "export PATH=$PATH" >> /etc/bashrc \

160+ && echo "export NIX_PATH=$NIX_PATH" >> /etc/bashrc \

161+ && echo "source /etc/bashrc" >> /etc/profile

162+

163+|] <> T.unlines

164+ [ "ADD " <> T.pack sshKeyFileName <> " /root/.ssh/id_rsa"

165+ , "ADD " <> T.pack (sshKeyFileName <.> "pub") <> " /root/.ssh/authorized_keys"

166+ ] <> [hereLit|

167+

168+EXPOSE 22

169+CMD ["/nix/store/hpnx760s247labqc3nbn2kripk73p0ca-openssh-7.6p1/bin/sshd", "-D", "-e"]

170+|]

171+

172+sshKeyFileName :: FilePath

173+sshKeyFileName = "id_ed25519_obelisk_vm"