Skip to content

GitLab

Commit 9e6d3ca6 authored by Valentin Reis's avatar Valentin Reis
Browse files

argonix refactor turtle -> protolude

parent 82498192
Pipeline #5834 passed with stage
in 22 seconds
Hide whitespace changes
Inline Side-by-side
Showing with 278 additions and 193 deletions
argonix.cabal
View file @ 9e6d3ca6
......@@ -19,9 +19,14 @@ executable argonix
text,
ansi-terminal,
neat-interpolation,
process,
typed-process,
bytestring,
directory,
filepath,
hscolour,
foldl,
system-filepath
system-filepath,
protolude
default-language: Haskell2010
ghc-options:
-threaded
......
default.nix
View file @ 9e6d3ca6
{
pkgs ? import <argopkgs> {},
pkgs ? import <argopkgs> {argonix-src = ./.;},
}:
rec {
argonix = pkgs.argonix.overrideAttrs (old:{
src = ./.;
});
argonix = pkgs.argonix;
hack = pkgs.argolib.getHackEnv pkgs pkgs.haskellPackages argonix;
......
src/Argonix.hs
View file @ 9e6d3ca6
{-# language RecordWildCards #-}
{-# language ApplicativeDo #-}
{-# language NoImplicitPrelude #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
......@@ -17,58 +18,56 @@ module Main
where
import Data.Default
import Turtle hiding ( header
, text
, arguments
)
import Protolude
import Options.Applicative
import Data.Maybe
import Prelude hiding ( FilePath )
import Data.Text ( pack
, unpack
import qualified Data.Text as T
( lines
, isInfixOf
, unwords
)
import System.Console.ANSI
import qualified System.Directory as SD
import System.Console.ANSI.Types ( Color )
import Turtle.Shell
import Control.Foldl
import System.Posix.Process
import qualified System.Process as P
( createProcess
import qualified System.Process.Typed as P
( runProcess
, runProcess_
, setEnv
, readProcessStdout_
, proc
, shell
)
import System.IO hiding ( FilePath )
-- | Miscellaneous printing utilities
colorShell :: Color -> Shell () -> Shell ()
colorShell color she = setC color *> she *> setC White
where setC c = liftIO $ setSGR [SetColor Foreground Dull c]
verboseShell :: Bool -> Text -> Shell Line -> Shell ExitCode
verboseShell v c i = when v (printCommand c) >> shell c i
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")
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
b <- liftIO
$ Turtle.Shell.fold (grep (has "nosuid") findmnt) Control.Foldl.length
when (b > 0) $ die $ format
("The output directory, " % fp % ", must not mounted with \"nosuid\"")
workingDirectory
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\""
)
main :: IO ()
main = do
hSetBuffering System.IO.stdout NoBuffering
join $ execParser (info (opts <**> helper) idm)
main = SIO.hSetBuffering SIO.stdout SIO.NoBuffering
<> void (join (execParser (info (opts <**> helper) idm)))
where
opts :: Parser (IO ())
opts = hsubparser
......@@ -97,7 +96,7 @@ data ArgsCommon = ArgsCommon
{ argopkgs :: Text
, verbosity :: Verbosity
, run :: Maybe Text
, overrides :: [(String, String)]
, overrides :: [(Text, Text)]
, grafting :: Grafting
, sandboxing :: Sandboxing
} deriving (Show)
......@@ -105,12 +104,21 @@ data Verbosity = Verbose | Normal deriving (Show, Eq)
data Sandboxing = Sandbox | NoSandbox deriving (Show, Eq)
data Grafting = Libnrm | NoGraft deriving (Show, Eq)
data NixStaticInOut = Both Text
| Src Text
| Target Text deriving (Eq)
data NixCommand = NixBuild | NixShell
data ArgsRemote = ArgsRemote
{ targetMachine
, retreive
, retreiveAs :: Maybe Text
} deriving (Show)
toCommand :: NixCommand -> Text
toCommand NixBuild = "nix-build"
toCommand NixShell = "nix-shell"
instance Default ArgsCommon where
def = ArgsCommon
{ verbosity = Normal,
......@@ -128,9 +136,68 @@ instance Default ArgsRemote where
retreiveAs = Nothing
}
targetParser :: Parser String
targetParser =
strArgument (metavar "TARGET" <> showDefault <> help "The build target.")
targets :: [Text]
targets = mapMaybe toTarget nixStatic
where
toTarget (Target t) = Just t
toTarget (Both t) = Just t
toTarget _ = Nothing
sources :: [Text]
sources = mapMaybe toSrc nixStatic
where
toSrc (Src t) = Just t
toSrc (Both t) = Just t
toSrc _ = Nothing
isTarget :: Text -> Bool
isTarget x = Target x `elem` nixStatic
nixStatic :: [NixStaticInOut]
nixStatic = src <> both <> target
where
src = [Src "experiments"]
both =
Both
<$> [ "aml"
, "libnrm"
, "numabench"
, "nrm"
, "containers"
, "argotk"
, "amg"
, "lammps"
, "qmcpack"
, "stream"
, "openmc"
, "argonix"
]
target =
Target
<$> [ "powerexpe"
, "test"
, "report"
, "testHello"
, "testListen"
, "testListen"
, "testHello"
, "testListen"
, "testPerfwrapper"
, "testPower"
, "testSTREAM"
, "testAMG"
, "testOpenMC"
, "testLAMMPS"
, "testQMCPack"
, "testAll"
]
targetParser :: Parser Text
targetParser = strArgument
(metavar "TARGET" <> showDefault <> help
(toS ("The build target, in " <> mconcat ts))
)
where ts = intersperse " " targets
remoteParser :: Parser ArgsRemote
remoteParser = do
......@@ -171,148 +238,183 @@ commonParser = do
(long "grafting" <> short 'g' <> help
"Enable libnrm grafting to avoid rebuilding applications."
)
overrides <- catMaybes <$> targets
overrides <- catMaybes <$> ts
run <- optional $ strOption
(long "run" <> metavar "COMMAND" <> help
"Command to run the environment instead of an interactive shell"
)
pure ArgsCommon {..}
where
targets :: Parser [Maybe (String, String)]
targets = traverse
optSrc
[ "aml"
, "libnrm"
, "numabench"
, "nrm"
, "containers"
, "argotk"
, "amg"
, "lammps"
, "qmcpack"
, "stream"
, "openmc"
, "experiments"
]
optSrc :: String -> Parser (Maybe (String, String))
ts :: Parser [Maybe (Text, Text)]
ts = traverse optSrc sources
optSrc :: Text -> Parser (Maybe (Text, Text))
optSrc longform = do
parsed <- optional $ strOption
(long longform <> metavar "PATH" <> help
(longform <> " source folder override.")
(long (toS longform) <> metavar "PATH" <> help
(toS longform <> " source folder override.")
)
pure $ mapT longform parsed
mapT :: String -> Maybe String -> Maybe (String, String)
mapT :: Text -> Maybe Text -> Maybe (Text, Text)
mapT longform thePath = case thePath of
Nothing -> Nothing
Just p -> Just (longform, p)
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
sudoRemoveFile :: Text -> FilePath -> IO ()
sudoRemoveFile desc filePath = do
P.runProcess_ (P.shell $ "test " <> filePath)
putText $ "found file " <> desc <> " at " <> toS filePath <> ".. "
go False
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"
socketList :: [FilePath]
socketList =
[ "/tmp/nrm-downstream-in"
, "/tmp/nrm-downstream-event"
, "/tmp/nrm-upstream-in"
, "/tmp/nrm-upstream-event"
]
setupSystem :: ArgsCommon -> Shell ()
setupSystem sa = do
doVerbose $ printInfo "Setting the nix-build environment up."
doVerbose $ printInfo "Cleaning sockets."
Prelude.mapM_ cleanSocket socketList
doVerbose $ printInfo "Setting up a cache directory:"
cachedir <- single
$ inproc "mktemp" ["-d", "/tmp/deletable-nix-cache-XXXX"] empty
export "XDG_CACHE_HOME" $ lineToText cachedir
doVerbose $ printInfo $ lineToText cachedir <> " exported to XDG_CACHE_HOME"
vshell "sudo rm -rf result" empty >>= \case
ExitSuccess -> printInfo "removed ./result"
ExitFailure n -> die ("Failed to remove ./result " <> repr n)
vshell "sudo rm -rf nixtmpdir" empty >>= \case
ExitSuccess -> printInfo "removed ./nixtmpdir"
ExitFailure n -> die ("Failed to remove ./nixtmpdir " <> repr n)
doVerbose $ printInfo "running nix-build for the containers attribute."
doVerbose $ printCommand $ "nix-build " <> pack
(unwords (nixArguments "containers" sa))
nodeos_config <- single $ inproc
"nix-build"
(fmap pack (nixArguments "containers" sa ++ ["--no-out-link"]))
empty
doVerbose $ printInfo "Checking filesystem attributes on /tmp"
checkFsAttributes "/tmp"
vshell "sudo rm -rf /tmp/argo_nodeos_config" empty
vshell
(format ("cp " % s % "/bin/argo_nodeos_config /tmp/argo_nodeos_config")
(lineToText nodeos_config)
)
empty
vshell "sudo chown root:root /tmp/argo_nodeos_config" empty >>= \case
ExitSuccess -> return ()
ExitFailure n ->
die ("Failed to set argo_nodeos_config permissions " <> repr n)
vshell "sudo chmod u+sw /tmp/argo_nodeos_config" empty >>= \case
ExitSuccess -> return ()
ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
vshell "sudo /tmp/argo_nodeos_config --clean_config=kill_content:true" empty
liftIO $ createAndSetTMPDIR "nixtmpdir"
void $ printInfo "Done setting the environment for nix-build up."
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
where
vshell = verboseShell verbose
verbose = verbosity sa == Verbose
doVerbose = when verbose
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)
readProcessVerbose :: Verbosity -> Text -> [Text] -> [(Text, Text)] -> IO Text
readProcessVerbose verbosity name arguments envVars = do
putVerbose verbosity $ name <> mconcat (intersperse " " arguments)
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
Nothing -> die "readProcess returned more than one line."
setupSystem :: Text -> ArgsCommon -> IO [(Text, Text)]
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)
varXDG_CACHE_HOME <- rpVerbose "mktemp" ["-d", "/tmp/deletable-nix-cache-XXXX"] []
varTMPDIR <- createAndSetTMPDIR "nixtmpdir"
varNIX_PATH <- toS <$> SE.getEnv "NIX_PATH"
let envVars =
[ ("XDG_CACHE_HOME", varXDG_CACHE_HOME)
, ("TMPDIR" , varTMPDIR)
, ("NIX_PATH" , varNIX_PATH)
]
when (isTarget target) $ setupNodeOs envVars
return envVars
where
setupNodeOs :: [(Text,Text)] -> IO ()
setupNodeOs env= do
cleanSockets $ verbosity sa
checkFsAttributes (verbosity sa) "/tmp"
nodeos_config <- rpVerbose
"nix-build"
(fmap toS (nixArguments "containers" sa) ++ ["--no-out-link"])
env
sVerbose "sudo rm -rf /tmp/argo_nodeos_config"
sVerbose
$ "cp "
<> toS nodeos_config
<> "/bin/argo_nodeos_config /tmp/argo_nodeos_config"
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 ()
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)
sVerbose = shellVerbose $ verbosity sa
rpVerbose = readProcessVerbose $ verbosity sa
createAndSetTMPDIR :: Text -> IO Text
createAndSetTMPDIR name = do
{-localpath <- (</> fromText name) <$> pwd-}
let path = "/tmp" </> fromText name
testpath path >>= flip when (rmtree path >> mkdir path)
case toText path of
Right p -> sh $ do
shell ("chmod 777 " <> p) empty >>= \case
ExitSuccess -> printf ("Successfully chmod" % s % "\n") p
ExitFailure _ -> die "failed at chmod"
shell ("ln -s " <> p <> " " <> name) empty >>= \case
ExitSuccess -> printf ("Successfully ln -s" % s % "\n") p
ExitFailure _ -> die "failed at ln -s"
export "TMPDIR" p
printInfo $ format ("TMPDIR exported to " % s) p
Left _ -> die "Path error when setting TMPDIR"
nixArguments :: String -> ArgsCommon -> [String]
let p = "/tmp/" <> name
SD.createDirectoryIfMissing True (toS p)
sVerbose $ "chmod 777 " <> p
sVerbose $ "ln -s " <> p <> " " <> name
return $ toS p
nixArguments :: Text -> ArgsCommon -> [Text]
nixArguments target ArgsCommon {..} =
[unpack argopkgs, "-A", target]
[argopkgs, "-A", target]
++ concat [ ["--arg", longform <> "-src", p] | (longform, p) <- overrides ]
++ (if grafting == Libnrm then ["--arg", "graftLibnrm", "true"] else [])
++ (if v then ["-o", "/tmp/papa"] else [] ++ [ "--show-trace" | v ])
++ ["-o", "/tmp/papa"]
++ [ "--show-trace" | v ]
where v = verbosity == Verbose
data NixCommand = NixBuild | NixShell
toCommand :: IsString p => NixCommand -> p
toCommand NixBuild = "nix-build"
toCommand NixShell = "nix-shell"
wrap :: NixCommand -> Text -> ArgsCommon -> IO ()
wrap nixCommand target sa@ArgsCommon {..} = do
when (verbosity == Verbose) $ print sa
envVars <- setupSystem target sa
putText $ nixc <> " " <> T.unwords arglist
case nixCommand of
NixShell -> executeFile (toS nixc) True (fmap toS arglist) Nothing
NixBuild ->
P.runProcess_
(P.setEnv (fmap (\(x, y) -> (toS x, toS y)) envVars)
(P.proc (toS nixc) $ fmap toS arglist)
)
<> P.runProcess_ (P.proc "cp" ["-r", "/tmp/papa", "./result"])
where
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
-- Sources of impurity for this build are: "/tmp/ /etc/argo/ /var/run/
-- /var/lock/. Moreover, sandboxing is disabled, in particular because of:
......@@ -324,23 +426,3 @@ toCommand NixShell = "nix-shell"
{-, "--option"-}
{-, "extra-sandbox-paths"-}
{-, "/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)
void $ shell "echo \"TMPDIR=$TMPDIR\"" empty
void $ shell "echo \"XDG_CACHE_HOME=$XDG_CACHE_HOME\"" empty
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"])
where
nixc = toCommand nixCommand
arglist =
nixArguments target sa
++ ["--allow-new-privileges", "-K", "--option", "build-use-sandbox"]
++ [if sandboxing == Sandbox then "true" else "false"]
remotely :: String -> ArgsCommon -> ArgsRemote -> IO ()
remotely _ _ _ = putStrLn "unsupported in this version"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment