Nixwrap.hs 10.8 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
import           Protolude
import qualified Data.Text                     as T
22 23
                                                ( isInfixOf
                                                , lines
Valentin Reis's avatar
Valentin Reis committed
24
                                                )
Valentin Reis's avatar
Valentin Reis committed
25
import           Options.Applicative
Valentin Reis's avatar
Valentin Reis committed
26 27
import           System.Console.ANSI
import           System.Console.ANSI.Types      ( Color )
Valentin Reis's avatar
Valentin Reis committed
28
import           System.Posix.Process
29 30 31 32
import qualified System.Process.Typed          as P
                                                ( runProcess
                                                , runProcess_
                                                , setEnv
33
                                                , readProcessStdout
34
                                                , proc
35
                                                , shell
36
                                                )
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
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 <-
54 55 56 57 58
    P.readProcessStdout
        (P.shell $ "findmnt -T " <> workingDirectory <> " -o OPTIONS")
      >>= \case
            (ExitSuccess  , t) -> return t
            (ExitFailure _, _) -> die "failing running findmnt on /tmp"
59 60 61 62 63
  when (T.isInfixOf "nosuid" $ toS findmnt) $ die
    (  "The output directory, "
    <> toS workingDirectory
    <> " must not mounted with \"nosuid\""
    )
64 65

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

89 90
toCommand :: NixCommand -> Text
toCommand NixBuild = "nix-build"
Valentin Reis's avatar
Valentin Reis committed
91
toCommand NixTest  = "nix-build"
92 93 94 95 96 97 98 99
toCommand NixShell = "nix-shell"

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

101 102 103 104 105
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
106
 where
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
  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
132
 where
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
  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)

152 153
readProcessVerbose
  :: Verbosity -> Text -> [Text] -> [(Text, Text)] -> IO (ExitCode, Text)
154
readProcessVerbose verbosity name arguments envVars = do
Valentin Reis's avatar
Valentin Reis committed
155
  putVerbose verbosity $ name <> " " <> mconcat (intersperse " " arguments)
156 157 158 159
  P.readProcessStdout
      ( P.setEnv (fmap (\(x, y) -> (toS x, toS y)) envVars)
      $ P.proc (toS name) (fmap toS arguments)
      )
160
    >>= \case
161 162
          (exitcode, bs) ->
            return (exitcode, fromMaybe "" (head $ T.lines $ toS bs))
Valentin Reis's avatar
Valentin Reis committed
163

Valentin Reis's avatar
Valentin Reis committed
164
setupSystem :: Text -> ArgsCommon -> IO ([(Text, Text)], Text)
165 166 167 168 169 170 171 172 173 174
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)

175 176 177 178 179 180 181 182
  varXDG_CACHE_HOME <-
    rpVerbose "mktemp" ["-d", "/tmp/deletable-nix-cache-XXXX"] [] >>= \case
      (ExitSuccess  , t) -> return t
      (ExitFailure _, _) -> die "failed mktemp for XDG_CACHE_HOME"

  varTMPDIR <- rpVerbose "mktemp" ["-d", "/tmp/tmpdir-XXXX"] [] >>= \case
    (ExitSuccess  , t) -> return t
    (ExitFailure _, _) -> die "failed mktemp for TMPDIR"
Valentin Reis's avatar
Valentin Reis committed
183

Valentin Reis's avatar
Valentin Reis committed
184 185 186
  sVerbose ("chmod 777 " <> varTMPDIR) >>= \case
    ExitFailure _ -> die "chmod failed for tmpdir"
    ExitSuccess   -> return ()
Valentin Reis's avatar
Valentin Reis committed
187

Valentin Reis's avatar
Valentin Reis committed
188
  passVars <- getVars ["PATH", "NIX_PATH", "NIX_SSL_CERT_FILE"]
189 190

  let envVars =
Valentin Reis's avatar
Valentin Reis committed
191 192
        [("XDG_CACHE_HOME", varXDG_CACHE_HOME), ("TMPDIR", varTMPDIR)]
          ++ passVars
193

Valentin Reis's avatar
Valentin Reis committed
194 195 196 197
  nodeosVar <- if isTarget target
    then setupNodeOs envVars
      >> return [("ARGO_NODEOS_CONFIG", "/tmp/argo_nodeos_config")]
    else return []
198

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

  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
209 210
  setupNodeOs :: [(Text, Text)] -> IO ()
  setupNodeOs env = do
211 212
    cleanSockets $ verbosity sa
    checkFsAttributes (verbosity sa) "/tmp"
213 214 215 216 217 218 219
    nodeos_config <-
      rpVerbose "nix-build"
                (fmap toS (nixArguments "containers" sa) ++ ["--no-out-link"])
                env
        >>= \case
              (ExitSuccess  , t) -> return t
              (ExitFailure _, _) -> die "failed building containers"
Valentin Reis's avatar
Valentin Reis committed
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
Valentin Reis's avatar
Valentin Reis committed
225
        (  "cp "
Valentin Reis's avatar
Valentin Reis committed
226 227 228 229 230 231 232
        <> 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)
233 234 235 236 237 238
    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
239 240 241 242 243 244 245
      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)
246 247
  sVerbose  = shellVerbose (verbosity sa)
  rpVerbose = readProcessVerbose (verbosity sa)
248 249

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

260 261 262
wrap :: NixCommand -> Text -> ArgsCommon -> IO ()
wrap nixCommand target sa@ArgsCommon {..} = do
  when (verbosity == Verbose) $ print sa
263 264 265
  (envVars, tmpDir) <- setupSystem
    (if nixCommand == NixTest then "testGeneric" else target)
    sa
266
  case nixCommand of
Valentin Reis's avatar
Valentin Reis committed
267 268
    NixShell ->
      executeFile (toS nixc) True (fmap toS arglist) (Just $ evC envVars)
269 270 271 272 273 274
    NixTest -> rpv (toS nixc) (fmap toS arglistTest) envVars >>= \case
      (ExitSuccess  , _) -> copySuccess "/tmp/papa"
      (ExitFailure _, _) -> copyFailure (toS tmpDir) >> die "build failed."
    NixBuild -> rpv (toS nixc) (fmap toS arglist) envVars >>= \case
      (ExitSuccess  , _) -> copySuccess "/tmp/papa"
      (ExitFailure _, _) -> copyFailure (toS tmpDir) >> die "build failed."
275
 where
Valentin Reis's avatar
Valentin Reis committed
276
  evC = fmap (\(x, y) -> (toS x, toS y))
277
  copySuccess source = do
278 279 280 281 282 283 284 285 286
    rpv "cp" ["--no-preserve=mode", "-Hr", source, "./result"] [] >>= \case
      (ExitFailure _, _) -> die "failed copying back the result from the store"
      (ExitSuccess  , _) -> return ()
    rpv "find" ["./result", "-type", "l", "-delete"] [] >>= \case
      (ExitFailure _, _) -> die "failed deleting links"
      (ExitSuccess  , _) -> return ()
    rpv "chmod" ["-R", "+w", "./result"] [] >>= \case
      (ExitFailure _, _) -> die "failed changing the mode of the result"
      (ExitSuccess  , _) -> return ()
287
  copyFailure source = do
288 289 290 291 292 293 294
    rpv "cp" ["--no-preserve=mode", "-r", source, "./nixtmpdir"] [] >>= \case
      (ExitFailure _, _) -> die "failed copying the failed build dir."
      (ExitSuccess  , _) -> return ()

    rpv "chmod" ["-R", "+w", "./nixtmpdir"] [] >>= \case
      (ExitFailure _, _) -> die "failed changing perms on the failure dir."
      (ExitSuccess  , _) -> return ()
Valentin Reis's avatar
Valentin Reis committed
295

Valentin Reis's avatar
Valentin Reis committed
296
  nixc    = toCommand nixCommand
297
  rpv     = readProcessVerbose verbosity
298

299
  arglist = nixArguments target sa ++ extraBuildArgs
Valentin Reis's avatar
Valentin Reis committed
300
  arglistTest =
301 302 303
    nixArguments "testGeneric" sa
      ++ ["--argstr", "genericTestName", target]
      ++ extraBuildArgs
Valentin Reis's avatar
Valentin Reis committed
304

Valentin Reis's avatar
Valentin Reis committed
305 306 307
  extraBuildArgs =
    ["--allow-new-privileges", "-K", "--option", "build-use-sandbox"]
      ++ [if sandboxing == Sandbox then "true" else "false"]