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

module Argo.Stack where
12
import           Argo.Args
13 14

import           Turtle
15
import           Turtle.Shell
16 17 18 19 20 21
import           Prelude                 hiding ( FilePath )

import           System.IO                      ( withFile )
import           Debug.Trace
import           Filesystem.Path                ( (</>) )
import           Control.Concurrent.Async
22
import           System.Console.ANSI
23
import           System.Console.ANSI.Types      ( Color )
24
import           Data.Text                     as T
25 26 27
                                         hiding ( empty )
import           Data.Text.IO                  as Text
import           Argo.Utils
28 29
import           System.Process                as P
                                         hiding ( shell )
30
import           Options.Applicative           as OA
31
import           Control.Monad.Extra           as E
32 33 34 35 36 37 38 39
import           Control.Monad                 as CM
import           Control.Foldl                 as F
import           Data.Conduit
import           Data.Conduit.Process
import           Data.ByteString.Char8         as C8
                                         hiding ( empty )
import           Control.Exception.Base
import           Data.Maybe
40
import           Control.Foldl                 as Fold
41

42

43 44 45 46 47 48 49 50
cleanLeftoverProcesses :: Shell ()
cleanLeftoverProcesses = do
  printInfo "Cleaning leftover processes.\n"
  daemon <- myWhich "daemon"
  verboseShell (format ("pkill " % fp) daemon) empty
  cmd <- myWhich "cmd"
  void $ verboseShell (format ("pkill " % fp) cmd) empty
  daemon_wrapped <- myWhichMaybe ".daemon-wrapped"
51 52
  E.whenJust daemon_wrapped
             (\x -> void $ verboseShell "pkill .daemon-wrapped" empty)
53
  cmd_wrapped <- myWhichMaybe ".cmd-wrapped"
54 55
  void $ E.whenJust cmd_wrapped
                    (\x -> void $ verboseShell "pkill .cmd-wrapped" empty)
56

57 58
cleanLeftovers :: StackArgs -> Shell ()
cleanLeftovers StackArgs {..} = do
59 60
  cleanLeftoverProcesses
  printInfo "Cleaning leftover files.\n"
61
  CM.mapM_
62
    cleanLog
63 64 65 66 67 68 69
    [ workingDirectory </> daemon_out
    , workingDirectory </> daemon_err
    , workingDirectory </> cmd_out
    , workingDirectory </> cmd_err
    , workingDirectory </> nrm_log
    , workingDirectory </> ".argo_nodeos_config_exit_message"
    , workingDirectory </> "argo_nodeos_config"
70
    ]
71
  printInfo "Cleaning leftover sockets.\n"
72
  CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
73

74 75 76 77 78 79 80 81 82 83 84
checkFsAttributes :: StackArgs -> Shell ()
checkFsAttributes StackArgs {..} = do
  let x = case toText workingDirectory of
        Left  x -> x
        Right x -> x
  let findmnt = inproc "findmnt" ["-T", x, "-o", "OPTIONS"] empty
  b <- liftIO $ Turtle.Shell.fold (grep (has "nosuid") findmnt) Fold.length
  when (b > 0) $ dieRed $ format
    ("The output directory, " % fp % ", must not mounted with \"nosuid\"")
    workingDirectory

85 86
prepareDaemon
  :: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ())))
87
prepareDaemon sa@StackArgs {..} = do
88
  mktree workingDirectory
89
  checkFsAttributes sa
90
  cd workingDirectory
91
  myWhich "daemon"
92 93
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
94 95 96
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
97
  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
98 99 100
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
101
  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
102 103
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
104 105
  verboseShell (format (fp % " --clean_config=kill_content:true") confPath')
               empty
106 107 108 109 110 111 112 113 114 115 116
    >>= \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)
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
117 118 119 120 121 122 123
  makeInstrumentedProcess $ Instrumentation
    { process    = P.proc "daemon" ["--nrm_log", encodeString nrm_log]
    , stdOutFile = daemon_out
    , stdErrFile = daemon_err
    , messageOut = messageDaemonOut
    , messageErr = messageDaemonErr
    }
124

125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
prepareCmdRun
  :: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ())))
prepareCmdRun StackArgs {..} = makeInstrumentedProcess $ Instrumentation
  { process    = P.proc "cmd"
    $  [ "run"
       , "-u"
       , T.unpack containerName
       , encodeString $ manifestDir </> manifestName
       , T.unpack app
       ]
    ++ fmap T.unpack args
  , stdOutFile = cmd_out
  , stdErrFile = cmd_err
  , messageOut = messageCmdOut
  , messageErr = messageCmdErr
  }
141

142 143 144
data StackOutput = FoundMessage | DaemonDied | CmdDied
runSimpleStack :: StackArgs -> Shell StackOutput
runSimpleStack a@StackArgs {..} = do
145
  cleanLeftovers a
146 147
  instrumentedDaemon <- prepareDaemon a
  instrumentedCmd    <- prepareCmdRun a
Valentin Reis's avatar
Valentin Reis committed
148
  printInfo "Running the daemon.."
149
  liftIO $ withAsync instrumentedDaemon $ \daemon -> do
150
    kbInstallHandler $ cancel daemon
Valentin Reis's avatar
Valentin Reis committed
151 152
    sh $ printInfo "Daemon running.\n"
    sh $ printInfo "Running cmd.."
153
    withAsync instrumentedCmd $ \cmd -> do
Valentin Reis's avatar
Valentin Reis committed
154
      sh $ printInfo "cmd running.\n"
155 156
      kbInstallHandler $ cancel daemon >> cancel cmd
      waitEitherCancel daemon cmd >>= \case
157 158 159 160
        Left  (Left  PatternMatched) -> return FoundMessage
        Left  (Right _             ) -> return DaemonDied
        Right (Left  PatternMatched) -> return FoundMessage
        Right (Right _             ) -> return CmdDied