Nixwrap.hs 9.94 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 #-}

Valentin Reis's avatar
Valentin Reis committed
6
{-|
Valentin Reis's avatar
Valentin Reis committed
7
Module      : Argonix
Valentin Reis's avatar
Valentin Reis committed
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
-}
Valentin Reis's avatar
Valentin Reis committed
13

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

Valentin Reis's avatar
Valentin Reis committed
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
                                                )
Valentin Reis's avatar
Valentin Reis committed
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"
Valentin Reis's avatar
Valentin Reis committed
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"
Valentin Reis's avatar
Valentin Reis committed
79
         (info (wrap NixShell <$> targetParser <*> commonParser)
Valentin Reis's avatar
Valentin Reis committed
80
               (progDesc "Enter an argo-compatible nix-shell")
81
         )
Valentin Reis's avatar
Valentin Reis committed
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
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
103

104 105 106 107 108
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
109
 where
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
  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
135
 where
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
  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
155
readProcessVerbose :: Verbosity -> Text -> [Text] -> [(Text, Text)] -> IO Text
156
readProcessVerbose verbosity name arguments envVars = do
Valentin Reis's avatar
Valentin Reis committed
157
  putVerbose verbosity $ name <> " " <> mconcat (intersperse " " arguments)
158 159 160 161 162 163 164 165 166
  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
Valentin Reis's avatar
Valentin Reis committed
167
          Nothing -> return ""
168

Valentin Reis's avatar
Valentin Reis committed
169 170 171
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
172
setupSystem :: Text -> ArgsCommon -> IO ([(Text, Text)], Text)
173 174 175 176 177 178 179 180 181 182
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
183 184 185
  varXDG_CACHE_HOME <- rpVerbose "mktemp"
                                 ["-d", "/tmp/deletable-nix-cache-XXXX"]
                                 []
Valentin Reis's avatar
Valentin Reis committed
186

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

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

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

  when (isTarget target) $ setupNodeOs envVars

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

  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
210 211
  setupNodeOs :: [(Text, Text)] -> IO ()
  setupNodeOs env = do
212 213 214 215 216 217
    cleanSockets $ verbosity sa
    checkFsAttributes (verbosity sa) "/tmp"
    nodeos_config <- rpVerbose
      "nix-build"
      (fmap toS (nixArguments "containers" sa) ++ ["--no-out-link"])
      env
Valentin Reis's avatar
Valentin Reis committed
218 219 220 221
    sVerbose "sudo rm -rf /tmp/argo_nodeos_config" >>= \case
      ExitSuccess -> return ()
      ExitFailure n ->
        die ("Failed to remove /tmp/argo_nodeos_config" <> show n)
222
    sVerbose
Valentin Reis's avatar
Valentin Reis committed
223
        (  "cp "
Valentin Reis's avatar
Valentin Reis committed
224 225 226 227 228 229 230
        <> toS nodeos_config
        <> "/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
    ++ (if offline then ["--option", "binary-caches", "null"] else [])
255
  where v = verbosity == Verbose
256

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

-- 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
294
  {-, "/tmp/ /etc/argo/ /var/run/ /var/lock/"-}