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

14 15 16 17
module Main
  ( main
  )
where
Valentin Reis's avatar
Valentin Reis committed
18 19 20 21 22 23 24 25 26 27 28 29 30

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
31 32 33 34
import           System.Console.ANSI
import           System.Console.ANSI.Types      ( Color )
import           Turtle.Shell
import           Control.Foldl
Valentin Reis's avatar
Valentin Reis committed
35
import           System.Posix.Process
36 37 38 39
import qualified System.Process                as P
                                                ( createProcess
                                                , proc
                                                )
Valentin Reis's avatar
Valentin Reis committed
40
import           System.IO               hiding ( FilePath )
Valentin Reis's avatar
Valentin Reis committed
41

Valentin Reis's avatar
Valentin Reis committed
42 43 44 45
-- | 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
46 47
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
48 49 50 51 52 53 54
printInfo :: Text -> Shell ()
printCommand :: Text -> Shell ()
printWarning :: Text -> Shell ()

printInfo = printf ("Info: " % s % "\n")
printCommand = printf ("Running: " % s % "\n")
printWarning = colorShell Yellow . printf ("Warning: " % s % "\n")
Valentin Reis's avatar
Valentin Reis committed
55

56 57 58 59 60 61
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
62 63
  b <- liftIO
    $ Turtle.Shell.fold (grep (has "nosuid") findmnt) Control.Foldl.length
64 65 66 67 68
  when (b > 0) $ die $ format
    ("The output directory, " % fp % ", must not mounted with \"nosuid\"")
    workingDirectory

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

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

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

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

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

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

Valentin Reis's avatar
Valentin Reis committed
135 136
remoteParser :: Parser ArgsRemote
remoteParser = do
Valentin Reis's avatar
Valentin Reis committed
137 138 139 140 141 142 143 144 145 146 147 148
  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
149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
  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
164 165 166 167
  sandboxing <- flag
    NoSandbox
    Sandbox
    (long "sandboxing" <> short 's' <> help "Enable nix sandboxing.")
Valentin Reis's avatar
Valentin Reis committed
168 169 170 171 172 173
  grafting <- flag
    NoGraft
    Libnrm
    (long "grafting" <> short 'g' <> help
      "Enable libnrm grafting to avoid rebuilding applications."
    )
Valentin Reis's avatar
Valentin Reis committed
174
  overrides <- catMaybes <$> targets
Valentin Reis's avatar
Valentin Reis committed
175 176 177 178
  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
179
  pure ArgsCommon {..}
Valentin Reis's avatar
Valentin Reis committed
180
 where
Valentin Reis's avatar
Valentin Reis committed
181 182
  targets :: Parser [Maybe (String, String)]
  targets = traverse
Valentin Reis's avatar
Valentin Reis committed
183
    optSrc
Valentin Reis's avatar
Valentin Reis committed
184 185
    [ "aml"
    , "libnrm"
Valentin Reis's avatar
Valentin Reis committed
186
    , "numabench"
Valentin Reis's avatar
Valentin Reis committed
187 188
    , "nrm"
    , "containers"
Valentin Reis's avatar
Valentin Reis committed
189
    , "argotk"
Valentin Reis's avatar
Valentin Reis committed
190 191 192 193
    , "amg"
    , "lammps"
    , "qmcpack"
    , "stream"
Valentin Reis's avatar
Valentin Reis committed
194
    , "openmc"
Valentin Reis's avatar
Valentin Reis committed
195
    , "experiments"
Valentin Reis's avatar
Valentin Reis committed
196
    ]
Valentin Reis's avatar
Valentin Reis committed
197
  optSrc :: String -> Parser (Maybe (String, String))
Valentin Reis's avatar
Valentin Reis committed
198 199 200 201 202 203
  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
204
  mapT :: String -> Maybe String -> Maybe (String, String)
Valentin Reis's avatar
Valentin Reis committed
205 206 207 208
  mapT longform thePath = case thePath of
    Nothing -> Nothing
    Just p  -> Just (longform, p)

Valentin Reis's avatar
Valentin Reis committed
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233
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"
234

Valentin Reis's avatar
Valentin Reis committed
235 236 237 238 239 240 241 242
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
243
setupSystem :: ArgsCommon -> Shell ()
Valentin Reis's avatar
Valentin Reis committed
244
setupSystem sa = do
Valentin Reis's avatar
Valentin Reis committed
245 246
  doVerbose $ printInfo "Setting the nix-build environment up."
  doVerbose $ printInfo "Cleaning sockets."
Valentin Reis's avatar
Valentin Reis committed
247
  Prelude.mapM_ cleanSocket socketList
Valentin Reis's avatar
Valentin Reis committed
248
  doVerbose $ printInfo "Setting up a cache directory:"
Valentin Reis's avatar
Valentin Reis committed
249 250
  cachedir <- single
    $ inproc "mktemp" ["-d", "/tmp/deletable-nix-cache-XXXX"] empty
251
  export "XDG_CACHE_HOME" $ lineToText cachedir
Valentin Reis's avatar
Valentin Reis committed
252
  doVerbose $ printInfo $ lineToText cachedir <> " exported to XDG_CACHE_HOME"
Valentin Reis's avatar
Valentin Reis committed
253
  vshell "sudo rm -rf result" empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
254 255
    ExitSuccess   -> printInfo "removed ./result"
    ExitFailure n -> die ("Failed to remove ./result " <> repr n)
Valentin Reis's avatar
Valentin Reis committed
256
  vshell "sudo rm -rf nixtmpdir" empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
257 258
    ExitSuccess   -> printInfo "removed ./nixtmpdir"
    ExitFailure n -> die ("Failed to remove ./nixtmpdir " <> repr n)
Valentin Reis's avatar
Valentin Reis committed
259
  doVerbose $ printInfo "running nix-build for the containers attribute."
Valentin Reis's avatar
Valentin Reis committed
260 261
  doVerbose $ printCommand $ "nix-build " <> pack
    (unwords (nixArguments "containers" sa))
262 263 264 265
  nodeos_config <- single $ 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
295
          ExitSuccess   -> printf ("Successfully chmod" % s % "\n") p
Valentin Reis's avatar
Valentin Reis committed
296
          ExitFailure _ -> die "failed at chmod"
Valentin Reis's avatar
bugfix.  
Valentin Reis committed
297
        shell ("ln -s " <> p <> " " <> name) empty >>= \case
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 [])
309 310
    ++ (if v then ["-o", "/tmp/papa"] else [] ++ [ "--show-trace" | v ])
  where v = verbosity == Verbose
311

Valentin Reis's avatar
Valentin Reis committed
312 313 314 315 316 317 318 319 320 321 322 323 324 325
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
326 327 328 329 330 331
  {-, "/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)
332 333
  void $ shell "echo \"TMPDIR=$TMPDIR\"" empty
  void $ shell "echo \"XDG_CACHE_HOME=$XDG_CACHE_HOME\"" empty
334 335 336 337
  liftIO $ case nixCommand of
    NixShell -> executeFile nixc True arglist Nothing
    NixBuild -> P.createProcess (P.proc nixc arglist)
      >> P.createProcess (P.proc "cp" ["-r", "/tmp/papa", "./result"])
Valentin Reis's avatar
Valentin Reis committed
338 339
 where
  nixc = toCommand nixCommand
Valentin Reis's avatar
Valentin Reis committed
340 341
  arglist =
    nixArguments target sa
342
      ++ ["--allow-new-privileges", "-K", "--option", "build-use-sandbox"]
Valentin Reis's avatar
Valentin Reis committed
343 344
      ++ [if sandboxing == Sandbox then "true" else "false"]

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