Stack.hs 7.74 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
{-# LANGUAGE ScopedTypeVariables, LambdaCase , RecordWildCards , OverloadedStrings ,
  DataKinds , FlexibleInstances , TypeOperators #-}

module Argo.Stack where

import           Data.Default
import           Turtle
import           Prelude                 hiding ( FilePath )

import           System.IO                      ( withFile )
import           Debug.Trace
import           Filesystem.Path                ( (</>) )
import           Control.Concurrent.Async
14
import           System.Console.ANSI
15 16 17 18 19
import           System.Console.ANSI.Types      ( Color )
import           Data.Text                     as Text
                                         hiding ( empty )
import           Data.Text.IO                  as Text
import           Argo.Utils
20 21
import           System.Process                as P
                                         hiding ( shell )
22 23 24 25 26

data StackArgs = StackArgs
  { dargs                :: [Text]      --"Daemon arguments. Properly quote this."
  , app                  :: Text        --"Target application call, sh+path valid"
  , workingDirectory     :: FilePath    --"Working directory."
27 28
  , manifestDir          :: FilePath    --"Manifest lookup directory"
  , manifestName         :: FilePath    --"Manifest file name"
29 30 31 32 33 34 35 36 37 38 39
  , cmd_out              :: FilePath    --"Output file, application stdout"
  , cmd_err              :: FilePath    --"Output file, application stderr"
  , daemon_out           :: FilePath    --"Output file, daemon stdout"
  , daemon_err           :: FilePath    --"Output file, daemon stderr"
  , nrm_log              :: FilePath    --"Output file, daemon log"
  , time_file            :: FilePath  } --"Output file, application runtime"

instance Default StackArgs where
  def = StackArgs
    { dargs = []
    , app = "echo \"HelloWorld\""
40 41 42
    , workingDirectory = "_output"
    , manifestDir = "manifests"
    , manifestName = "basic.json"
43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
    , cmd_out = "cmd_out.log"
    , cmd_err = "cmd_err.log"
    , daemon_out = "daemon_out.log"
    , daemon_err = "daemon_err.log"
    , nrm_log = "nrm.log"
    , time_file = "time.log"
    }

cleanLeftovers
  :: FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> Shell ()
cleanLeftovers wd daemon_out daemon_err cmd_out cmd_err time_file nrm_log = do
  printInfo "Cleaning leftovers..\n"
  mapM_
    cleanLog
    [ wd </> daemon_out
    , wd </> daemon_err
    , wd </> cmd_out
    , wd </> cmd_err
    , wd </> time_file
    , wd </> nrm_log
    , wd </> ".argo_nodeos_config_exit_message"
71
    , wd </> "argo_nodeos_config"
72 73 74 75 76 77 78 79 80
    ]
  mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]

prepareDaemonShell
  :: FilePath -> [Text] -> FilePath -> FilePath -> FilePath -> Shell (IO ())
prepareDaemonShell wd dargs daemon_out daemon_err nrm_log = do
  mktree wd
  cd wd
  myWhich "daemon"
81 82
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
  shell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
  shell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)

  --Cleaning the config, running the daemon
  shell (format (fp % " --clean_config=kill_content:true") confPath') empty
    >>= \case
          ExitSuccess   -> printInfo "Cleaned the argo config.\n"
          ExitFailure n -> do
            printError
              ("argo_nodeos_config failed with exit code :" <> repr n <> "\n")
            testfile ".argo_nodeos_config_exit_message" >>= \case
              True -> do
                printInfo "Contents of .argo_nodeos_config_exit_message: \n"
                view $ input "./argo_nodeos_config_exit_message"
              False -> die ("Clean config failed with exit code " <> repr n)
  printInfo $ format
    ( "Running the daemon, main log at "
    % fp
    % ", stdout at "
    % fp
    % ", stderr at "
    % fp
    % "\n"
    )
    nrm_log
    daemon_out
    daemon_err
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
  return $ twoWayPrint daemon_out daemon_err $ inprocWithErr
    "daemon"
    (dargs ++ ["--nrm_log", Text.pack $ encodeString nrm_log])
    empty

-- | See at the bottom of this file for discussion of this function. (1)
cmdShell :: FilePath -> Text -> FilePath -> FilePath -> Shell ()
126
cmdShell manifest app cmd_out cmd_err =
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
  shell
      (format ("cmd run -u toto " % fp % "  " % s % " > " % fp % " 2>" % fp)
              manifest
              app
              cmd_out
              cmd_err
      )
      empty
    >>= \case
          ExitSuccess   -> printInfo "cmd has exited successfuly.\n"
          ExitFailure n -> die
            (  "cmd failed with exit code "
            <> repr n
            <> " . The application logs are at "
            <> repr cmd_out
            <> " "
            <> repr cmd_err
            )

twoWayPrint :: FilePath -> FilePath -> Shell (Either Line Line) -> IO ()
twoWayPrint outPath errPath s = sh $ do
  handleOut <- using (writeonly outPath)
  handleErr <- using (writeonly errPath)
  s >>= \case
    Left  out -> liftIO $ Text.hPutStrLn handleOut (lineToText out)
    Right err -> liftIO $ Text.hPutStrLn handleErr (lineToText err)

runSimpleStack :: StackArgs -> IO ()
runSimpleStack a@StackArgs {..} = sh $ do
  cleanLeftovers workingDirectory
                 daemon_out
                 daemon_err
                 cmd_out
                 cmd_err
                 time_file
                 nrm_log
  daemonShell <- prepareDaemonShell workingDirectory
                                    dargs
                                    daemon_out
                                    daemon_err
                                    nrm_log
  liftIO $ withAsync daemonShell $ \daemon -> do
    kbInstallHandler $ cancel daemon
170 171 172 173 174 175 176 177
    withAsync
        (time $ sh $ cmdShell (manifestDir </> manifestName) app cmd_out cmd_err
        )
      $ \cmd -> do
          kbInstallHandler $ cancel daemon >> cancel cmd
          waitEitherCancel daemon cmd >>= \case
            Left  _      -> die "Daemon died."
            Right (_, t) -> writeTextFile time_file (repr t)
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210

-- | (1)
--
-- | This version fucks up the environment variables. issue at
-- https://github.com/Gabriel439/Haskell-Turtle-Library/issues/338
{-cmdShell :: FilePath -> Text -> FilePath -> FilePath -> Shell ()-}
{-cmdShell manifest app cmd_out cmd_err = do-}
  {-manifestArg <- case toText manifest of-}
    {-Left m -> printWarning (format ("Manifest path malformed: " % fp) manifest)-}
      {->> return m-}
    {-Right m -> return m-}
  {-printInfo $ format-}
    {-("Running cmd. Stdout at " % fp % ", stderr at " % fp % "\n")-}
    {-cmd_out-}
    {-cmd_err-}
  {-liftIO $ twoWayPrint cmd_out cmd_err $ inprocWithErr-}
    {-"cmd"-}
    {-["run", "-u", "toto", manifestArg, app]-}
    {-empty-}

-- | Even this one fucks up, streamWithErr really cleans this `env` attribute.

  {-manifestArg <- case toText manifest of-}
    {-Left m -> printWarning (format ("Manifest path malformed: " % fp) manifest)-}
      {->> return m-}
    {-Right m -> return m-}
  {-printInfo $ format-}
    {-("Running cmd. Stdout at " % fp % ", stderr at " % fp % "\n")-}
    {-cmd_out-}
    {-cmd_err-}
  {-theEnv' <- liftIO $ Turtle.env-}
  {-let theEnv = Prelude.map (\(x,y)-> (Text.unpack x,Text.unpack y)) theEnv'-}
  {-void $ liftIO $  twoWayPrint cmd_out cmd_err $ streamWithErr ((P.proc (unpack "cmd") (Prelude.map unpack ["run", "-u", "toto", manifestArg, app])) {P.env=Just theEnv}) empty-}