Argonix.hs 11.8 KB
Newer Older
Valentin Reis's avatar
Valentin Reis committed
1
2
{-# language RecordWildCards #-}
{-# language ApplicativeDo #-}
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
7
8
9
10
{-|
Module      : Main
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
Valentin Reis committed
14
15
16
17
18
19
20
21
22
23
24
25
26
27
module Main where

import           Data.Default
import           Turtle                  hiding ( header
                                                , text
                                                , arguments
                                                )
import           Options.Applicative
import           Data.Maybe
import           Prelude                 hiding ( FilePath )

import           Data.Text                      ( pack
                                                , unpack
                                                )
Valentin Reis's avatar
Valentin Reis committed
28
29
30
31
import           System.Console.ANSI
import           System.Console.ANSI.Types      ( Color )
import           Turtle.Shell
import           Control.Foldl
Valentin Reis's avatar
Valentin Reis committed
32
import           System.Posix.Process
Valentin Reis's avatar
Valentin Reis committed
33
import           System.IO               hiding ( FilePath )
Valentin Reis's avatar
Valentin Reis committed
34

Valentin Reis's avatar
Valentin Reis committed
35
36
37
38
-- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell ()
colorShell color she = setC color *> she *> setC White
  where setC c = liftIO $ setSGR [SetColor Foreground Dull c]
Valentin Reis's avatar
Valentin Reis committed
39
40
verboseShell :: Bool -> Text -> Shell Line -> Shell ExitCode
verboseShell v c i = when v (printCommand c) >> shell c i
Valentin Reis's avatar
Valentin Reis committed
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
printInfo :: Text -> Shell ()
printCommand :: Text -> Shell ()
printError :: Text -> Shell ()
printWarning :: Text -> Shell ()
printSuccess :: Text -> Shell ()
printTest :: Text -> Shell ()
dieRed :: Text -> Shell ()

printInfo = printf ("Info: " % s % "\n")
printCommand = printf ("Running: " % s % "\n")
printWarning = colorShell Yellow . printf ("Warning: " % s % "\n")
printError = colorShell Red . printf ("Error: " % s % "\n")
printSuccess = colorShell Green . printf ("Success: " % s % "\n")
printTest = colorShell Green . printf ("RUNNING TEST: " % s % "\n")
dieRed strw =
  colorShell Red (printf ("Failure: " % s) strw) >> exit (ExitFailure 1)
Valentin Reis's avatar
Valentin Reis committed
57

58
59
60
61
62
63
checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do
  let dir = case toText workingDirectory of
        Left  di -> di
        Right di -> di
  let findmnt = inproc "findmnt" ["-T", dir, "-o", "OPTIONS"] empty
Valentin Reis's avatar
Valentin Reis committed
64
65
  b <- liftIO
    $ Turtle.Shell.fold (grep (has "nosuid") findmnt) Control.Foldl.length
66
67
68
69
70
  when (b > 0) $ die $ format
    ("The output directory, " % fp % ", must not mounted with \"nosuid\"")
    workingDirectory

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

Valentin Reis's avatar
Valentin Reis committed
98
data ArgsCommon = ArgsCommon
Valentin Reis's avatar
Valentin Reis committed
99
100
101
102
103
  { argopkgs   :: Text
   , verbosity :: Verbosity
   , run       :: Maybe Text
   , overrides :: [(String, String)]
   , grafting  :: Grafting
Valentin Reis's avatar
Valentin Reis committed
104
   , sandboxing :: Sandboxing
Valentin Reis's avatar
Valentin Reis committed
105
  } deriving (Show)
Valentin Reis's avatar
Valentin Reis committed
106
data Verbosity = Verbose | Normal deriving (Show, Eq)
Valentin Reis's avatar
Valentin Reis committed
107
data Sandboxing = Sandbox | NoSandbox deriving (Show, Eq)
Valentin Reis's avatar
Valentin Reis committed
108
data Grafting = Libnrm | NoGraft deriving (Show, Eq)
Valentin Reis's avatar
Valentin Reis committed
109

Valentin Reis's avatar
Valentin Reis committed
110
data ArgsRemote = ArgsRemote
Valentin Reis's avatar
style    
Valentin Reis committed
111
112
  {  targetMachine
   , retreive
Valentin Reis's avatar
Valentin Reis committed
113
114
115
116
117
   , retreiveAs    :: Maybe Text
  } deriving (Show)

instance Default ArgsCommon where
  def = ArgsCommon
Valentin Reis's avatar
Valentin Reis committed
118
119
120
121
122
123
    { verbosity  = Normal,
      argopkgs   = "<argopkgs>",
      run        = Nothing,
      overrides  = [],
      grafting   = NoGraft,
      sandboxing = NoSandbox
Valentin Reis's avatar
Valentin Reis committed
124
125
    }

Valentin Reis's avatar
Valentin Reis committed
126
127
128
instance Default ArgsRemote where
  def = ArgsRemote
    { targetMachine = Nothing,
Valentin Reis's avatar
Valentin Reis committed
129
130
      retreive      = Nothing,
      retreiveAs    = Nothing
Valentin Reis's avatar
Valentin Reis committed
131
132
    }

133
134
135
136
targetParser :: Parser String
targetParser =
  strArgument (metavar "TARGET" <> showDefault <> help "The build target.")

Valentin Reis's avatar
Valentin Reis committed
137
138
remoteParser :: Parser ArgsRemote
remoteParser = do
Valentin Reis's avatar
Valentin Reis committed
139
140
141
142
143
144
145
146
147
148
149
150
  retreive <- optional $ strOption
    (long "retreive" <> metavar "RELATIVE_PATH" <> help
      "File/Folder to retreive from the remote machine."
    )
  retreiveAs <- optional $ strOption
    (long "retreiveAs" <> metavar "LOCAL_PATH" <> help
      "File/Folder to save retreived data as (locally)."
    )
  targetMachine <- optional $ strOption
    (long "target_machine" <> metavar "USER@HOST" <> help
      "Target machine. defaults to localhost via forking."
    )
Valentin Reis's avatar
Valentin Reis committed
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
  pure ArgsRemote {..}

commonParser :: Parser ArgsCommon
commonParser = do
  argopkgs <- strOption
    (  long "argopkgs"
    <> metavar "ARGOPKGS"
    <> showDefault
    <> value (argopkgs def)
    <> help "Nix expression that produces the argopkgs source path."
    )
  verbosity <- flag
    Normal
    Verbose
    (long "verbose" <> short 'v' <> help "Enable verbose mode")
Valentin Reis's avatar
Valentin Reis committed
166
167
168
169
  sandboxing <- flag
    NoSandbox
    Sandbox
    (long "sandboxing" <> short 's' <> help "Enable nix sandboxing.")
Valentin Reis's avatar
Valentin Reis committed
170
171
172
173
174
175
  grafting <- flag
    NoGraft
    Libnrm
    (long "grafting" <> short 'g' <> help
      "Enable libnrm grafting to avoid rebuilding applications."
    )
Valentin Reis's avatar
Valentin Reis committed
176
  overrides <- catMaybes <$> targets
Valentin Reis's avatar
Valentin Reis committed
177
178
179
180
  run       <- optional $ strOption
    (long "run" <> metavar "COMMAND" <> help
      "Command to run the environment instead of an interactive shell"
    )
Valentin Reis's avatar
Valentin Reis committed
181
  pure ArgsCommon {..}
Valentin Reis's avatar
Valentin Reis committed
182
 where
Valentin Reis's avatar
Valentin Reis committed
183
184
  targets :: Parser [Maybe (String, String)]
  targets = traverse
Valentin Reis's avatar
Valentin Reis committed
185
    optSrc
Valentin Reis's avatar
Valentin Reis committed
186
187
    [ "aml"
    , "libnrm"
Valentin Reis's avatar
Valentin Reis committed
188
    , "numabench"
Valentin Reis's avatar
Valentin Reis committed
189
190
    , "nrm"
    , "containers"
Valentin Reis's avatar
Valentin Reis committed
191
    , "argotk"
Valentin Reis's avatar
Valentin Reis committed
192
193
194
195
    , "amg"
    , "lammps"
    , "qmcpack"
    , "stream"
Valentin Reis's avatar
Valentin Reis committed
196
    , "openmc"
Valentin Reis's avatar
Valentin Reis committed
197
    , "experiments"
Valentin Reis's avatar
Valentin Reis committed
198
    ]
Valentin Reis's avatar
Valentin Reis committed
199
  optSrc :: String -> Parser (Maybe (String, String))
Valentin Reis's avatar
Valentin Reis committed
200
201
202
203
204
205
  optSrc longform = do
    parsed <- optional $ strOption
      (long longform <> metavar "PATH" <> help
        (longform <> " source folder override.")
      )
    pure $ mapT longform parsed
Valentin Reis's avatar
Valentin Reis committed
206
  mapT :: String -> Maybe String -> Maybe (String, String)
Valentin Reis's avatar
Valentin Reis committed
207
208
209
210
  mapT longform thePath = case thePath of
    Nothing -> Nothing
    Just p  -> Just (longform, p)

Valentin Reis's avatar
Valentin Reis committed
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
sudoRemoveFile :: (Text -> Shell ()) -> Text -> FilePath -> Shell ()
sudoRemoveFile printer desc filePath = do
  foundSocket <- testfile filePath
  when foundSocket $ go False
  printInfo $ format ("OK: " % s % " " % fp) desc filePath
 where
  go useSudo = do
    printer $ format ("found file " % s % " at " % fp % ".. ") desc filePath
    shell
        (format ((if useSudo then "sudo " else "") % "rm -rf " % fp) filePath)
        Turtle.empty
      >>= \case
            ExitSuccess -> colorShell Green $ printf " Successfully removed.\n"
            ExitFailure _ -> if useSudo
              then printer $ format
                ("Failed to remove file " % s % ", even with sudo.")
                desc
              else do
                printer $ format
                  ("Failed to remove file " % s % ". Trying sudo..\n")
                  desc
                go True

cleanSocket :: FilePath -> Shell ()
cleanSocket = sudoRemoveFile printWarning "socket"
236

Valentin Reis's avatar
Valentin Reis committed
237
238
239
240
241
242
243
244
socketList :: [FilePath]
socketList =
  [ "/tmp/nrm-downstream-in"
  , "/tmp/nrm-downstream-event"
  , "/tmp/nrm-upstream-in"
  , "/tmp/nrm-upstream-event"
  ]

Valentin Reis's avatar
Valentin Reis committed
245
setupSystem :: ArgsCommon -> Shell ()
Valentin Reis's avatar
Valentin Reis committed
246
setupSystem sa = do
Valentin Reis's avatar
Valentin Reis committed
247
248
  doVerbose $ printInfo "Setting the nix-build environment up."
  doVerbose $ printInfo "Cleaning sockets."
Valentin Reis's avatar
Valentin Reis committed
249
  Prelude.mapM_ cleanSocket socketList
Valentin Reis's avatar
Valentin Reis committed
250
  doVerbose $ printInfo "Setting up a cache directory:"
Valentin Reis's avatar
Valentin Reis committed
251
252
  cachedir <- single
    $ inproc "mktemp" ["-d", "/tmp/deletable-nix-cache-XXXX"] empty
253
  export "XDG_CACHE_HOME" $ lineToText cachedir
Valentin Reis's avatar
Valentin Reis committed
254
  doVerbose $ printInfo $ lineToText cachedir <> " exported to XDG_CACHE_HOME"
Valentin Reis's avatar
Valentin Reis committed
255
  vshell "sudo rm -rf result" empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
256
257
    ExitSuccess   -> printInfo "removed ./result"
    ExitFailure n -> die ("Failed to remove ./result " <> repr n)
Valentin Reis's avatar
Valentin Reis committed
258
  vshell "sudo rm -rf nixtmpdir" empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
259
260
    ExitSuccess   -> printInfo "removed ./nixtmpdir"
    ExitFailure n -> die ("Failed to remove ./nixtmpdir " <> repr n)
Valentin Reis's avatar
Valentin Reis committed
261
  doVerbose $ printInfo "running nix-build for the containers attribute."
Valentin Reis's avatar
Valentin Reis committed
262
263
  doVerbose $ printCommand $ "nix-build " <> pack
    (unwords (nixArguments "containers" sa))
Valentin Reis's avatar
Valentin Reis committed
264
  nodeos_config <- single
Valentin Reis's avatar
Valentin Reis committed
265
    $ inproc "nix-build" (fmap pack (nixArguments "containers" sa ++ ["--no-out-link"])) empty
Valentin Reis's avatar
Valentin Reis committed
266
  doVerbose $ printInfo "Checking filesystem attributes on /tmp"
267
  checkFsAttributes "/tmp"
Valentin Reis's avatar
Valentin Reis committed
268
269
  vshell "sudo rm -rf /tmp/argo_nodeos_config" empty
  vshell
Valentin Reis's avatar
Valentin Reis committed
270
271
272
273
    (format ("cp " % s % "/bin/argo_nodeos_config /tmp/argo_nodeos_config")
            (lineToText nodeos_config)
    )
    empty
Valentin Reis's avatar
Valentin Reis committed
274
  vshell "sudo chown root:root /tmp/argo_nodeos_config" empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
275
276
277
    ExitSuccess -> return ()
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
Valentin Reis's avatar
Valentin Reis committed
278
  vshell "sudo chmod u+sw /tmp/argo_nodeos_config" empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
279
280
    ExitSuccess   -> return ()
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
Valentin Reis's avatar
Valentin Reis committed
281
  vshell "sudo /tmp/argo_nodeos_config --clean_config=kill_content:true" empty
Valentin Reis's avatar
Valentin Reis committed
282
  liftIO $ createAndSetTMPDIR "nixtmpdir"
Valentin Reis's avatar
Valentin Reis committed
283
  void $ printInfo "Done setting the environment for nix-build up."
Valentin Reis's avatar
Valentin Reis committed
284
285
286
287
 where
  vshell    = verboseShell verbose
  verbose   = verbosity sa == Verbose
  doVerbose = when verbose
Valentin Reis's avatar
Valentin Reis committed
288
  createAndSetTMPDIR name = do
Valentin Reis's avatar
Valentin Reis committed
289
290
    {-localpath <- (</> fromText name) <$> pwd-}
    let path = "/tmp" </> fromText name
Valentin Reis's avatar
Valentin Reis committed
291
    testpath path >>= flip when (rmtree path >> mkdir path)
Valentin Reis's avatar
Valentin Reis committed
292
    case toText path of
Valentin Reis's avatar
Valentin Reis committed
293
      Right p -> sh $ do
Valentin Reis's avatar
Valentin Reis committed
294
        shell ("chmod 777 " <> p) empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
295
          ExitSuccess   -> printf ("Successfully chmod" % s %"\n") p
Valentin Reis's avatar
Valentin Reis committed
296
297
          ExitFailure _ -> die "failed at chmod"
        shell ("ln -s " <> p <> name) empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
298
          ExitSuccess   -> printf ("Successfully ln -s" % s %"\n") p
Valentin Reis's avatar
Valentin Reis committed
299
          ExitFailure _ -> die "failed at ln -s"
Valentin Reis's avatar
Valentin Reis committed
300
        export "TMPDIR" p
Valentin Reis's avatar
Valentin Reis committed
301
        printInfo $ format ("TMPDIR exported to " % s) p
Valentin Reis's avatar
Valentin Reis committed
302
      Left _ -> die "Path error when setting TMPDIR"
303

Valentin Reis's avatar
Valentin Reis committed
304
nixArguments :: String -> ArgsCommon -> [String]
Valentin Reis's avatar
Valentin Reis committed
305
306
307
nixArguments target ArgsCommon {..} =
  [unpack argopkgs, "-A", target]
    ++ concat [ ["--arg", longform <> "-src", p] | (longform, p) <- overrides ]
Valentin Reis's avatar
Valentin Reis committed
308
    ++ (if grafting == Libnrm then ["--arg", "graftLibnrm", "true"] else [])
Valentin Reis's avatar
Valentin Reis committed
309
    ++ [ "--show-trace" | verbosity == Verbose ]
310

Valentin Reis's avatar
Valentin Reis committed
311
312
313
314
315
316
317
318
319
320
321
322
323
324
data NixCommand = NixBuild | NixShell
toCommand :: IsString p => NixCommand -> p
toCommand NixBuild = "nix-build"
toCommand NixShell = "nix-shell"

-- Sources of impurity for this build are: "/tmp/ /etc/argo/ /var/run/
-- /var/lock/. Moreover, sandboxing is disabled, in particular because of:
-- /tmp/nrm-* sockets, /etc/argo, /var/run/, /var/lock/ which all need read
-- access.  until these components are patched to allow for alternative paths,
-- 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
325
326
327
328
329
330
  {-, "/tmp/ /etc/argo/ /var/run/ /var/lock/"-}
wrap :: NixCommand -> String -> ArgsCommon -> IO ()
wrap nixCommand target sa@ArgsCommon {..} = sh $ do
  when (verbosity == Verbose) $ liftIO $ print sa
  _ <- setupSystem sa
  printCommand $ pack nixc <> " " <> pack (unwords arglist)
331
332
  void $ shell "echo \"TMPDIR=$TMPDIR\"" empty
  void $ shell "echo \"XDG_CACHE_HOME=$XDG_CACHE_HOME\"" empty
Valentin Reis's avatar
Valentin Reis committed
333
334
335
  liftIO (executeFile nixc True arglist Nothing)
 where
  nixc = toCommand nixCommand
Valentin Reis's avatar
Valentin Reis committed
336
337
338
339
340
341
342
343
  arglist =
    nixArguments target sa
      ++ [ "--pure"
         , "--allow-new-privileges"
         , "-K"
         , "--option"
         , "build-use-sandbox"
         ]
Valentin Reis's avatar
Valentin Reis committed
344
345
      ++ [if sandboxing == Sandbox then "true" else "false"]

Valentin Reis's avatar
Valentin Reis committed
346
remotely :: String -> ArgsCommon -> ArgsRemote -> IO ()
Valentin Reis's avatar
Valentin Reis committed
347
remotely _ _ _ = putStrLn "unsupported in this version"