Nixwrap.hs 9.81 KB
Newer Older
Valentin Reis's avatar
Valentin Reis committed
1
{-# language RecordWildCards #-}
2
{-# language NoImplicitPrelude #-}
Valentin Reis's avatar
Valentin Reis committed
3
{-# language LambdaCase #-}
Valentin Reis's avatar
Valentin Reis committed
4 5
{-# language OverloadedStrings #-}

6
{-|
7
Module      : Argonix
8 9 10
Description : argonix
Copyright   : (c) Valentin Reis, 2018
License     : MIT
Valentin Reis's avatar
Valentin Reis committed
11 12
Maintainer  : fre@freux.fr
-}
13

Valentin Reis's avatar
Valentin Reis committed
14
module Nixwrap
15 16 17
  ( main
  )
where
Valentin Reis's avatar
Valentin Reis committed
18

19
import           Args
20 21 22 23 24
import           Protolude
import qualified Data.Text                     as T
                                                ( lines
                                                , isInfixOf
                                                , unwords
Valentin Reis's avatar
Valentin Reis committed
25
                                                )
26
import           Options.Applicative
Valentin Reis's avatar
Valentin Reis committed
27 28
import           System.Console.ANSI
import           System.Console.ANSI.Types      ( Color )
Valentin Reis's avatar
Valentin Reis committed
29
import           System.Posix.Process
30 31 32 33 34
import qualified System.Process.Typed          as P
                                                ( runProcess
                                                , runProcess_
                                                , setEnv
                                                , readProcessStdout_
35
                                                , proc
36
                                                , shell
37
                                                )
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
import           System.Exit                    ( ExitCode )
import qualified System.IO                     as SIO
                                                ( hSetBuffering
                                                , stdout
                                                , BufferMode(..)
                                                )
import qualified System.Environment            as SE

-- | color printing
colorIn :: Color -> IO () -> IO ()
colorIn color she = setC color *> she *> setC White
  where setC c = setSGR [SetColor Foreground Dull c]

checkFsAttributes :: Verbosity -> FilePath -> IO ()
checkFsAttributes verbosity workingDirectory = do
  putVerbose verbosity "Checking filesystem attributes on /tmp"
  findmnt <-
    P.readProcessStdout_
    $  P.shell
    $  "findmnt -T "
    <> workingDirectory
    <> " -o OPTIONS"
  when (T.isInfixOf "nosuid" $ toS findmnt) $ die
    (  "The output directory, "
    <> toS workingDirectory
    <> " must not mounted with \"nosuid\""
    )
65 66

main :: IO ()
67 68
main = SIO.hSetBuffering SIO.stdout SIO.NoBuffering
  <> void (join (execParser (info (opts <**> helper) idm)))
69 70 71 72 73
 where
  opts :: Parser (IO ())
  opts = hsubparser
    (  command
        "build"
74
        (info (wrap NixBuild <$> targetParser <*> commonParser)
75 76 77
              (progDesc "Run an argo-compatible nix-build.")
        )
    <> command
Valentin Reis's avatar
Valentin Reis committed
78
         "shell"
79
         (info (wrap NixShell <$> targetParser <*> commonParser)
Valentin Reis's avatar
Valentin Reis committed
80
               (progDesc "Enter an argo-compatible nix-shell")
81
         )
82 83 84 85 86 87 88 89
    <> command
         "remote-shell"
         (info
           (remotely <$> targetParser <*> commonParser <*> remoteParser)
           (progDesc
             "Enter an argo-compatible nix-shell on a remote machine with nix enabled"
           )
         )
90 91 92
    <> help "Type of operation to run."
    )

93 94 95 96 97 98 99 100 101 102 103
toCommand :: NixCommand -> Text
toCommand NixBuild = "nix-build"
toCommand NixShell = "nix-shell"


targetParser :: Parser Text
targetParser = strArgument
  (metavar "TARGET" <> showDefault <> help
    (toS ("The build target, in " <> mconcat ts))
  )
  where ts = intersperse " " targets
104

105 106 107 108 109
sudoRemoveFile :: Text -> FilePath -> IO ()
sudoRemoveFile desc filePath = do
  P.runProcess_ (P.shell $ "test " <> filePath)
  putText $ "found file " <> desc <> " at " <> toS filePath <> ".. "
  go False
Valentin Reis's avatar
Valentin Reis committed
110
 where
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
  go useSudo = P.runProcess (sudorm useSudo) >>= \case
    ExitSuccess   -> colorIn Green $ putText "Successfully removed."
    ExitFailure _ -> if useSudo then reportFailure else trySudo
  sudorm useSudo =
    P.shell $ (if useSudo then "sudo " else "") <> "rm -rf " <> filePath
  trySudo = do
    putText
      $  "Failed to remove "
      <> desc
      <> " at "
      <> toS filePath
      <> ". Trying sudo..\n"
    go True
  reportFailure =
    colorIn Red
      $  putText
      $  "Failed to remove "
      <> desc
      <> " at "
      <> toS filePath
      <> ", even with sudo."


cleanSockets :: Verbosity -> IO ()
cleanSockets verbosity =
  putVerbose verbosity "cleaning sockets" >> for_ socketList cleanSocket
Valentin Reis's avatar
Valentin Reis committed
137
 where
138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
  cleanSocket :: FilePath -> IO ()
  cleanSocket = sudoRemoveFile "socket"

  socketList :: [FilePath]
  socketList =
    [ "/tmp/nrm-downstream-in"
    , "/tmp/nrm-downstream-event"
    , "/tmp/nrm-upstream-in"
    , "/tmp/nrm-upstream-event"
    ]

putVerbose :: MonadIO m => Verbosity -> Text -> m ()
putVerbose verbosity = when (verbosity == Verbose) . putText

shellVerbose :: MonadIO m => Verbosity -> Text -> m ExitCode
shellVerbose verbosity s = do
  putVerbose verbosity s
  P.runProcess (P.shell $ toS s)

Valentin Reis's avatar
Valentin Reis committed
157
readProcessVerbose :: Verbosity -> Text -> [Text] -> [(Text, Text)] -> IO Text
158
readProcessVerbose verbosity name arguments envVars = do
Valentin Reis's avatar
Valentin Reis committed
159
  putVerbose verbosity $ name <> " " <> mconcat (intersperse " " arguments)
160 161 162 163 164 165 166 167 168
  head
    .   T.lines
    .   toS
    <$> P.readProcessStdout_
          ( P.setEnv (fmap (\(x, y) -> (toS x, toS y)) envVars)
          $ P.proc (toS name) (fmap toS arguments)
          )
    >>= \case
          Just r  -> return r
169
          Nothing -> return ""
170

Valentin Reis's avatar
Valentin Reis committed
171 172 173
runProcessVerbose :: Verbosity -> Text -> [Text] -> [(Text, Text)] -> IO ()
runProcessVerbose a b c d = void $ readProcessVerbose a b c d

Valentin Reis's avatar
Valentin Reis committed
174
setupSystem :: Text -> ArgsCommon -> IO ([(Text, Text)], Text)
175 176 177 178 179 180 181 182 183 184
setupSystem target sa = do

  sVerbose "sudo rm -rf result" >>= \case
    ExitSuccess   -> putText "removed ./result"
    ExitFailure n -> die ("Failed to remove ./result " <> show n)

  sVerbose "sudo rm -rf nixtmpdir" >>= \case
    ExitSuccess   -> putText "removed ./nixtmpdir"
    ExitFailure n -> die ("Failed to remove ./nixtmpdir " <> show n)

Valentin Reis's avatar
Valentin Reis committed
185 186 187
  varXDG_CACHE_HOME <- rpVerbose "mktemp"
                                 ["-d", "/tmp/deletable-nix-cache-XXXX"]
                                 []
188

Valentin Reis's avatar
Valentin Reis committed
189
  varTMPDIR <- rpVerbose "mktemp" ["-d", "/tmp/tmpdir-XXXX"] []
190 191 192
  sVerbose ("chmod 777 " <> varTMPDIR) >>= \case
    ExitFailure _ -> die "chmod failed for tmpdir"
    ExitSuccess   -> return ()
Valentin Reis's avatar
Valentin Reis committed
193

Valentin Reis's avatar
Valentin Reis committed
194
  passVars <- getVars ["PATH", "NIX_PATH", "NIX_SSL_CERT_FILE"]
195 196

  let envVars =
Valentin Reis's avatar
Valentin Reis committed
197 198
        [("XDG_CACHE_HOME", varXDG_CACHE_HOME), ("TMPDIR", varTMPDIR)]
          ++ passVars
199 200 201

  when (isTarget target) $ setupNodeOs envVars

202
  return (envVars, varTMPDIR)
203
 where
Valentin Reis's avatar
Valentin Reis committed
204
  getVars :: [Text] -> IO [(Text, Text)]
205
  getVars vars = catMaybes <$> for vars maybeGet
Valentin Reis's avatar
Valentin Reis committed
206 207 208 209 210 211

  maybeGet :: Text -> IO (Maybe (Text, Text))
  maybeGet var = SE.lookupEnv (toS var) >>= \case
    Nothing  -> return Nothing
    Just val -> return $ Just (var, toS val)

Valentin Reis's avatar
Valentin Reis committed
212 213
  setupNodeOs :: [(Text, Text)] -> IO ()
  setupNodeOs env = do
214 215 216 217 218 219
    cleanSockets $ verbosity sa
    checkFsAttributes (verbosity sa) "/tmp"
    nodeos_config <- rpVerbose
      "nix-build"
      (fmap toS (nixArguments "containers" sa) ++ ["--no-out-link"])
      env
220 221 222 223
    sVerbose "sudo rm -rf /tmp/argo_nodeos_config" >>= \case
      ExitSuccess -> return ()
      ExitFailure n ->
        die ("Failed to remove /tmp/argo_nodeos_config" <> show n)
224
    sVerbose
225
      (  "cp "
226
      <> toS nodeos_config
227 228 229 230
      <> "/bin/argo_nodeos_config /tmp/argo_nodeos_config") >>= \case
      ExitSuccess -> return ()
      ExitFailure n ->
        die ("Failed to copy argo_nodeos_config" <> show n)
231 232 233 234 235 236
    sVerbose "sudo chown root:root /tmp/argo_nodeos_config" >>= \case
      ExitSuccess -> return ()
      ExitFailure n ->
        die ("Failed to set argo_nodeos_config permissions " <> show n)
    sVerbose "sudo chmod u+sw /tmp/argo_nodeos_config" >>= \case
      ExitSuccess -> return ()
Valentin Reis's avatar
Valentin Reis committed
237 238 239 240 241 242 243
      ExitFailure n ->
        die ("Setting suid bit failed with exit code " <> show n)
    sVerbose "sudo /tmp/argo_nodeos_config --clean_config=kill_content:true"
      >>= \case
            ExitSuccess -> return ()
            ExitFailure n ->
              die ("NodeOS config cleaning failed with exit code" <> show n)
244 245 246 247
  sVerbose  = shellVerbose $ verbosity sa
  rpVerbose = readProcessVerbose $ verbosity sa

nixArguments :: Text -> ArgsCommon -> [Text]
Valentin Reis's avatar
Valentin Reis committed
248
nixArguments target ArgsCommon {..} =
249
  [argopkgs, "-A", target]
Valentin Reis's avatar
Valentin Reis committed
250
    ++ concat [ ["--arg", longform <> "-src", p] | (longform, p) <- overrides ]
Valentin Reis's avatar
Valentin Reis committed
251
    ++ (if grafting == Libnrm then ["--arg", "graftLibnrm", "true"] else [])
252 253
    ++ ["-o", "/tmp/papa"]
    ++ [ "--show-trace" | v ]
254
  where v = verbosity == Verbose
255

256 257 258
wrap :: NixCommand -> Text -> ArgsCommon -> IO ()
wrap nixCommand target sa@ArgsCommon {..} = do
  when (verbosity == Verbose) $ print sa
259
  (envVars, tmpDir) <- setupSystem target sa
260 261 262
  putText $ nixc <> " " <> T.unwords arglist
  case nixCommand of
    NixShell -> executeFile (toS nixc) True (fmap toS arglist) Nothing
Valentin Reis's avatar
Valentin Reis committed
263 264
    NixBuild ->
      P.runProcess
265 266 267
          (P.setEnv (fmap (\(x, y) -> (toS x, toS y)) envVars)
                    (P.proc (toS nixc) $ fmap toS arglist)
          )
Valentin Reis's avatar
Valentin Reis committed
268
        >>= \case
269 270
              ExitSuccess   -> copySuccess "/tmp/papa"
              ExitFailure _ -> copyFailure (toS tmpDir) >> die "build failed."
271
 where
272
  copySuccess source = do
273 274
    runProcessVerbose verbosity "cp"    ["-Lr", source, "./result"] []
    runProcessVerbose verbosity "chmod" ["-R", "+w", "./result"]    []
275
  copyFailure source = do
276 277
    runProcessVerbose verbosity "cp"    ["-Lr", source, "./nixtmpdir"] []
    runProcessVerbose verbosity "chmod" ["-R", "+w", "./nixtmpdir"]    []
Valentin Reis's avatar
Valentin Reis committed
278

279 280 281 282 283 284 285 286
  nixc = toCommand nixCommand
  arglist =
    nixArguments target sa
      ++ ["--allow-new-privileges", "-K", "--option", "build-use-sandbox"]
      ++ [if sandboxing == Sandbox then "true" else "false"]

remotely :: Text -> ArgsCommon -> ArgsRemote -> IO ()
remotely _ _ _ = putText "unsupported in this version" >> undefined
Valentin Reis's avatar
Valentin Reis committed
287 288 289 290 291 292

-- no sandbox use is possible. If sandbox paths were read only we could add:
   {-, "--option"-}
   {-, "build-use-sandbox"-}
   {-, "--option"-}
   {-, "extra-sandbox-paths"-}
Valentin Reis's avatar
Valentin Reis committed
293
  {-, "/tmp/ /etc/argo/ /var/run/ /var/lock/"-}