Argonix.hs 10.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 11 12
{-|
Module      : Main
Description : argonix
Copyright   : (c) Valentin Reis, 2018
License     : MIT
Maintainer  : fre@freux.fr -}

Valentin Reis's avatar
Valentin Reis committed
13 14 15 16 17 18 19 20 21 22 23 24 25 26
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
                                                )
27 28
import Turtle.Shell
import Control.Foldl
Valentin Reis's avatar
Valentin Reis committed
29 30 31
import           System.Posix.Process


32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59
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

main :: IO ()
main = join $ execParser (info (opts <**> helper) idm)
 where
  opts :: Parser (IO ())
  opts = hsubparser
    (  command
        "build"
        (info (nixbuild <$> targetParser <*> executorParser)
              (progDesc "Run an argo-compatible nix-build.")
        )
    <> command
         "stack-shell"
         (info (pure nixshell) (progDesc "Enter an argo-compatable nix-shell")
         )
    <> help "Type of operation to run."
    )

Valentin Reis's avatar
Valentin Reis committed
60
data StackArgs = StackArgs
Valentin Reis's avatar
Valentin Reis committed
61 62 63
  {
    argopkgs      :: Text
   , verbosity     :: Verbosity
Valentin Reis's avatar
Valentin Reis committed
64 65 66 67 68 69 70 71 72 73 74 75
   , enableApps    :: Bool
   , remoteBuild   :: Bool
   , targetMachine :: Maybe Text
   , retreive      :: Maybe Text
   , retreiveAs    :: Maybe Text
   , run           :: Maybe Text
   , overrides     :: [(String, FilePath)]
  } deriving (Show)
data Verbosity = Verbose | Normal deriving (Show)

instance Default StackArgs where
  def = StackArgs
Valentin Reis's avatar
Valentin Reis committed
76 77
    { verbosity = Normal,
      argopkgs = "<argopkgs>",
Valentin Reis's avatar
Valentin Reis committed
78 79 80 81 82 83 84 85 86
      enableApps = False,
      remoteBuild = False,
      run = Nothing,
      targetMachine = Nothing,
      retreive = Nothing,
      retreiveAs = Nothing,
      overrides = []
    }

87 88 89 90
targetParser :: Parser String
targetParser =
  strArgument (metavar "TARGET" <> showDefault <> help "The build target.")

Valentin Reis's avatar
Valentin Reis committed
91 92
executorParser :: Parser StackArgs
executorParser = do
Valentin Reis's avatar
Valentin Reis committed
93 94 95 96 97 98 99
  argopkgs <- strOption
    (  long "argopkgs"
    <> metavar "ARGOPKGS"
    <> showDefault
    <> value (argopkgs def)
    <> help "Nix expression that produces the argopkgs source path."
    )
Valentin Reis's avatar
Valentin Reis committed
100 101 102 103 104 105 106 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 132 133 134 135 136 137
  verbosity <- flag
    Normal
    Verbose
    (long "verbose" <> short 'v' <> help "Enable verbose mode")
  enableApps <- flag
    False
    True
    (long "provision_apps" <> short 'a' <> help
      "Build and provision applications."
    )
  remoteBuild <- flag
    False
    True
    (long "remote_build" <> short 'r' <> help
      "Build on the remote rather than locally."
    )
  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."
    )
  overrides <- catMaybes <$> truc
  run       <- optional $ strOption
    (long "run" <> metavar "COMMAND" <> help
      "Command to run the environment instead of an interactive shell"
    )
  pure StackArgs {..}
 where
  truc :: Parser [Maybe (String, FilePath)]
  truc = traverse
    optSrc
Valentin Reis's avatar
Valentin Reis committed
138 139
    [ "aml"
    , "libnrm"
Valentin Reis's avatar
Valentin Reis committed
140 141
    , "nrm"
    , "containers"
Valentin Reis's avatar
Valentin Reis committed
142
    , "argotk"
Valentin Reis's avatar
Valentin Reis committed
143 144 145 146
    , "amg"
    , "lammps"
    , "qmcpack"
    , "stream"
Valentin Reis's avatar
Valentin Reis committed
147
    , "openmc"
Valentin Reis's avatar
Valentin Reis committed
148 149 150 151 152 153 154 155 156 157 158 159 160
    ]
  optSrc :: String -> Parser (Maybe (String, FilePath))
  optSrc longform = do
    parsed <- optional $ strOption
      (long longform <> metavar "PATH" <> help
        (longform <> " source folder override.")
      )
    pure $ mapT longform parsed
  mapT :: String -> Maybe FilePath -> Maybe (String, FilePath)
  mapT longform thePath = case thePath of
    Nothing -> Nothing
    Just p  -> Just (longform, p)

161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
envSetup :: Shell FilePath
envSetup = do
  sudo <- which "sudo" >>= \case
    (Just sudo) -> printf ("Found sudo at " % fp % "\n") sudo >> return sudo
    Nothing     -> die "sudo not in $PATH."
  export "SUDO" $ pack $ encodeString sudo
  cachedir <- single $ inproc
    "mktemp"
    ["-d", "--suffix=nixcache", "/tmp/deletable-nix-cache-XXXX"]
    empty
  export "XDG_CACHE_HOME" $ lineToText cachedir
  return $ directory sudo

setupNodeOS :: StackArgs -> Shell FilePath
setupNodeOS sa = do
  sudo <- which "sudo" >>= \case
    (Just sudo) -> printf ("Found sudo at " % fp % "\n") sudo >> return sudo
    Nothing     -> die "sudo not in $PATH."
  export "SUDO" $ pack $ encodeString sudo
  cachedir <- single $ inproc
    "mktemp"
    ["-d", "--suffix=nixcache", "/tmp/deletable-nix-cache-XXXX"]
    empty
  export "XDG_CACHE_HOME" $ lineToText cachedir
  nodeos_config <- single $ inproc "nix-build" (fmap pack (nixArguments "containers" sa)) empty
Valentin Reis's avatar
Valentin Reis committed
186
  printf  s "Checking filesystem attributes in /tmp\n"
187
  checkFsAttributes "/tmp"
Valentin Reis's avatar
Valentin Reis committed
188 189 190 191
  printf  s "Copying argo_nodeos_config to /tmp\n"
  shell "sudo rm -rf /tmp/argo_nodeos_config" empty
  shell (format ("cp "%s%"/bin/argo_nodeos_config /tmp/argo_nodeos_config") (lineToText nodeos_config)) empty
  printf  s "Trying to sudo chown and chmod argo_nodeos_config\n"
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
  shell "sudo chown root:root /tmp/argo_nodeos_config" empty
    >>= \case
          ExitSuccess -> printf s "Chowned argo_nodeos_config to root:root.\n"
          ExitFailure n ->
            die ("Failed to set argo_nodeos_config permissions " <> repr n)
  shell "sudo chmod u+sw /tmp/argo_nodeos_config"  empty
    >>= \case
          ExitSuccess -> printf s "Set the suid bit.\n"
          ExitFailure n ->
            die ("Setting suid bit failed with exit code " <> repr n)
  return $ directory sudo

nixArguments :: String -> StackArgs -> [String]
nixArguments target StackArgs {..} = [unpack argopkgs, "-A", target] ++ concat
  [ ["--arg", longform <> "-src", encodeString p] | (longform, p) <- overrides ]

nixbuild :: String -> StackArgs -> IO ()
nixbuild target sa@StackArgs {..} = sh $ do
  view $ single $ inshell "echo $SUDO" empty
Valentin Reis's avatar
Valentin Reis committed
211
  setupNodeOS sa
212 213 214 215 216 217 218 219 220 221 222 223 224 225
  let arglist =
        (  (nixArguments target sa)
        ++ [ "--pure"
           , "--allow-new-privileges"
           , "--option"
           , "extra-sandbox-paths"
           , "/tmp/argo_nodeos_config"
           , "-K"
           ]
        )
  liftIO $ print arglist
  liftIO $ executeFile "nix-build" True arglist Nothing

nixshell :: IO ()
Valentin Reis's avatar
Valentin Reis committed
226 227
nixshell = sh $ do undefined
  {-StackArgs {..} <- liftIO $ execParser opts-}
Valentin Reis's avatar
Valentin Reis committed
228

Valentin Reis's avatar
Valentin Reis committed
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
  {--- building nixArguments (pure stuff) and shellArguments (impure stuff)-}
  {-let nixArguments = ["-A", if enableApps then "expe" else "test"] ++ concat-}
        {-[ ["--arg", longform <> "-src", encodeString p]-}
        {-| (longform, p) <- overrides-}
        {-]-}
  {-sudo <- which "sudo" >>= \case-}
    {-(Just sudo) -> printf ("Found sudo at " % fp % "\n") sudo >> return sudo-}
    {-Nothing     -> die "sudo not in $PATH."-}
  {-export "SUDO" $ pack $ encodeString sudo-}
  {-let shellArguments =-}
        {-[unpack argopkgs]-}
          {-++ [ "--keep"-}
             {-, "SUDO"-}
             {-, "--pure"-}
             {-, "--allow-new-privileges"-}
             {-, "--option"-}
             {-, "build-extra-sandbox-paths"-}
             {-, encodeString (directory sudo)-}
             {-]-}
          {-++ nixArguments-}
          {-++ (case run of-}
               {-Just cmd -> ["--run", unpack ("\"exec " <> cmd <> "\"")]-}
               {-Nothing  -> []-}
             {-)-}
Valentin Reis's avatar
Valentin Reis committed
253

Valentin Reis's avatar
Valentin Reis committed
254 255 256 257 258 259 260 261 262 263 264 265 266
  {-cachedir <- single $ inproc-}
    {-"mktemp"-}
    {-["-d", "--suffix=nixcache", "/tmp/deletable-nix-cache-XXXX"]-}
    {-empty-}
  {-export "XDG_CACHE_HOME" $ lineToText cachedir-}
  {-case targetMachine of-}
    {-Nothing -> do-}
      {-printf s "Running nix-shell with the following arguments: \n"-}
      {-liftIO $ print shellArguments-}
      {-liftIO $ executeFile "nix-shell" True shellArguments Nothing-}
    {-Just host -> do-}
      {-export "NIX_SSHOPTS" "source .profile; source .bash_profile;"-}
      {-printf s "argonix: creating a derivation in the local store:\n"-}
Valentin Reis's avatar
Valentin Reis committed
267

Valentin Reis's avatar
Valentin Reis committed
268 269 270 271
      {-drv <- single $ inproc-}
        {-"nix-instantiate"-}
        {-(["--quiet", argopkgs, "-A", "test"] ++ fmap pack nixArguments)-}
        {-empty-}
Valentin Reis's avatar
Valentin Reis committed
272

Valentin Reis's avatar
Valentin Reis committed
273
      {-printf (s % "\n") $ lineToText drv-}
Valentin Reis's avatar
Valentin Reis committed
274

Valentin Reis's avatar
Valentin Reis committed
275 276 277 278 279 280 281 282 283
      {-if remoteBuild-}
        {-then do-}
          {-printf-}
            {-s-}
            {-"argonix: copying the derivation's closure (without build output).\n"-}
          {-proc "nix-copy-closure" ["--to", host, lineToText drv] empty-}
        {-else do-}
          {-printf s "argonix: building the derivation's output:\n"-}
          {-proc "nix-store" ["--realize", lineToText drv, "--quiet"] empty-}
Valentin Reis's avatar
Valentin Reis committed
284

Valentin Reis's avatar
Valentin Reis committed
285 286 287 288 289 290
          {-printf-}
            {-s-}
            {-"argonix: copying the derivation's closure (with build output).\n"-}
          {-proc "nix-copy-closure"-}
               {-["--include-outputs", "--to", host, lineToText drv]-}
               {-empty-}
Valentin Reis's avatar
Valentin Reis committed
291

Valentin Reis's avatar
Valentin Reis committed
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
      {-case run of-}
        {-Just cmd -> do-}
          {-_ <- proc-}
            {-"ssh"-}
            {-[ "-t"-}
            {-, host-}
            {-, "source .profile; source .bash_profile; SUDO=$(which sudo) exec nix-shell --keep SUDO --pure --allow-new-privileges --option build-extra-sandbox-paths $(which sudo | xargs dirname) "-}
            {-<> lineToText drv-}
            {-<> " --run "-}
            {-<> "\""-}
            {-<> cmd-}
            {-<> "\""-}
            {-]-}
            {-empty-}
          {-Prelude.mapM_-}
            {-(\r -> proc "scp"-}
                        {-["-r", host <> ":" <> r, fromMaybe "." retreiveAs]-}
                        {-empty-}
            {-)-}
            {-retreive-}
        {-Nothing -> liftIO $ executeFile-}
          {-"ssh"-}
          {-True-}
          {-[ "-t"-}
          {-, unpack host-}
          {-, unpack-}
            {-("source .profile; source .bash_profile; SUDO=$(which sudo) exec nix-shell --keep SUDO --pure --allow-new-privileges --option build-extra-sandbox-paths $(which sudo | xargs dirname) "-}
            {-<> lineToText drv-}
            {-)-}
          {-]-}
          {-Nothing-}
 {-where-}
  {-opts = info-}
    {-(executorParser <**> helper)-}
    {-(  fullDesc-}
    {-<> progDesc "Argo environment provisioning/deployment/execution."-}
    {-<> header "argonix"-}
    {-)-}