Stack.hs 7.98 KB
Newer Older
1
{-# LANGUAGE
Valentin Reis's avatar
Valentin Reis committed
2
  TupleSections,
3
  ScopedTypeVariables,
4 5 6 7 8 9 10
  LambdaCase,
  RecordWildCards,
  OverloadedStrings,
  DataKinds,
  FlexibleInstances,
  TypeOperators,
  ApplicativeDo #-}
11 12

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

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

import           Filesystem.Path                ( (</>) )
20

21
import           Control.Concurrent.Async
22

23
import           Data.Text                     as T
24 25
                                         hiding ( empty )
import           Argo.Utils
26 27
import           System.Process                as P
                                         hiding ( shell )
28 29
import           Control.Monad                 as CM
import           Data.Maybe
30
import           Control.Foldl                 as Fold
31
import           Text.Show.Pretty
32

Valentin Reis's avatar
Valentin Reis committed
33 34
cleanLeftovers :: WorkingDirectory -> Shell ()
cleanLeftovers (WorkingDirectory wd) = do
Valentin Reis's avatar
Valentin Reis committed
35
  printInfo "Cleaning working(output) directory.\n"
Valentin Reis's avatar
Valentin Reis committed
36
  cleanLog wd
Valentin Reis's avatar
Valentin Reis committed
37
  printInfo "Cleaning sockets.\n"
38
  CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
39

Valentin Reis's avatar
Valentin Reis committed
40 41
checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do
42 43 44 45
  let dir = case toText workingDirectory of
        Left  di -> di
        Right di -> di
  let findmnt = inproc "findmnt" ["-T", dir, "-o", "OPTIONS"] empty
46 47 48 49 50
  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

Valentin Reis's avatar
Valentin Reis committed
51
prepareDaemon
Valentin Reis's avatar
Valentin Reis committed
52
  :: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation
53 54
prepareDaemon out stdErr test = do
  _ <- myWhich "daemon"
55 56
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
57 58 59
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
60
  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
61 62 63
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
64
  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
65 66
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
67
  cleanContainers confPath' 1 2
68
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
69
  return $ Instrumentation (P.proc "daemon" []) out stdErr test
70
 where
71
  nodeOsFailure n = do
72 73 74 75
    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"
76
        view $ input ".argo_nodeos_config_exit_message"
77
      False -> die ("argo_nodeos_config failed with exit code " <> repr n)
78
  cleanContainers :: FilePath -> NominalDiffTime -> Integer ->  Shell ()
79 80 81 82 83 84 85 86
  cleanContainers argo_nodeos_config retryTime remainingRetries = do
    let
      showConfig =
        inshell (format (fp % " --show_config") argo_nodeos_config) empty
    verboseShell'
        (format (fp % " --clean_config=kill_content:true") argo_nodeos_config)
        empty
      >>= \case
87 88
            (ExitFailure n, _, _) -> do
              when (remainingRetries == 0) $ nodeOsFailure n
89 90 91 92 93 94 95 96 97 98 99
              printWarning
                (  "the argo_nodeos_config call failed with exit code "
                <> repr n
                <> ". Retrying..\n"
                )
              liftIO $ sleep (retryTime * 2)
              cleanContainers argo_nodeos_config
                              (retryTime * 2)
                              (remainingRetries - 1)
            (ExitSuccess, _, _) -> do
              printInfo "Cleaned the argo config.\n"
100
              len <- liftIO $ Turtle.Shell.fold
101 102
                (grep (has "CONTAINER") showConfig)
                Fold.length
103
              if len > 0
104 105 106 107 108 109 110 111 112 113 114
                then do
                  printWarning
                    "the argo_nodeos_config call did not remove containers, \
                \at least not fast enough. Retrying.."
                  liftIO $ sleep retryTime
                  cleanContainers argo_nodeos_config
                                  (retryTime * 2)
                                  (remainingRetries - 1)
                else
                  printInfo
                    "argo_nodeos_config successfully cleaned the container \
115
                \config.\n"
116

Valentin Reis's avatar
Valentin Reis committed
117 118
cmdRunI
  :: AppName
119
  -> [AppArg]
Valentin Reis's avatar
Valentin Reis committed
120 121 122 123 124
  -> ContainerName
  -> ManifestDir
  -> ManifestName
  -> ProcessBehavior
  -> Maybe (StackI, Instrumentation)
125
cmdRunI (AppName app) args (ContainerName cn) (ManifestDir md) (ManifestName mn) pb
Valentin Reis's avatar
Valentin Reis committed
126 127 128 129
  = Just (Run, )
    <*> processBehaviorToI
          (  P.proc "cmd"
          $  ["run", "-u", T.unpack cn, encodeString $ md </> mn, T.unpack app]
130
          ++ fmap (T.unpack . argToText) args
Valentin Reis's avatar
Valentin Reis committed
131 132
          )
          pb
133
  where argToText (AppArg a) = a
Valentin Reis's avatar
Valentin Reis committed
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148

cmdListenI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenI (ContainerName cn) pb =
  Just (Listen, )
    <*> processBehaviorToI (P.proc "cmd" ["listen", "-u", T.unpack cn]) pb

cmdListenProgressI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenProgressI (ContainerName cn) pb =
  Just (Progress, )
    <*> processBehaviorToI
          (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
          pb

149 150 151 152 153 154 155 156 157
cmdListenPerformanceI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPerformanceI (ContainerName cn) pb =
  Just (Performance, )
    <*> processBehaviorToI
          (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"]
          )
          pb

Valentin Reis's avatar
Valentin Reis committed
158 159 160 161 162 163 164 165 166 167 168 169
cmdListenPowerI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPowerI (ContainerName cn) pb =
  Just (Power, )
    <*> processBehaviorToI
          (P.proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
          pb

data StackOutput =
    FoundMessage
  | Died StackI ExitCode

170
data StackI = Daemon | Run | Listen | Progress | Power | Performance deriving (Show)
Valentin Reis's avatar
Valentin Reis committed
171

Valentin Reis's avatar
Valentin Reis committed
172
runStack :: StackArgs -> Shell StackOutput
173 174 175 176 177 178 179
runStack StackArgs {..} = do
  CM.mapM_
    cleanSocket
    [ "/tmp/nrm-downstream-in"
    , "/tmp/nrm-upstream-in"
    , "/tmp/nrm-upstream-event"
    ]
Valentin Reis's avatar
Valentin Reis committed
180
  let (WorkingDirectory wd) = workingDirectory
181
  _ <- Turtle.shell (format ("rm -rf " % fp) wd) Turtle.empty
Valentin Reis's avatar
Valentin Reis committed
182 183 184
  mktree wd
  checkFsAttributes wd
  cd wd
Valentin Reis's avatar
Valentin Reis committed
185 186 187

  iDaemon <- case daemon of
    DontRun -> return Nothing
188 189 190 191
    JustRun stdOut stdErr ->
      (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing
    SucceedTestOnMessage t stdOut stdErr ->
      (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr (Just t)
Valentin Reis's avatar
Valentin Reis committed
192 193 194 195 196

  let milist =
        [ iDaemon
        , cmdRunI app args containerName manifestDir manifestName cmdrun
        , cmdListenI containerName cmdlisten
197
        , cmdListenPerformanceI containerName cmdlistenperformance
Valentin Reis's avatar
Valentin Reis committed
198 199 200 201 202
        , cmdListenProgressI containerName cmdlistenprogress
        , cmdListenPowerI containerName cmdlistenpower
        ]
      ilist = catMaybes milist

203 204 205 206 207 208
  if verbosity == Verbose
    then do
      printInfo "Starting the following processes:\n"
      liftIO $ pPrint ilist
    else liftIO $ pPrint (fmap fst ilist)

Valentin Reis's avatar
Valentin Reis committed
209
  asyncs <- liftIO $ mapM tupleToAsync ilist
210
  _ <- liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
211 212 213

  when (verbosity == Verbose) $ printInfo "Processes started.\n"

Valentin Reis's avatar
Valentin Reis committed
214
  out <- liftIO $ waitAnyCancel asyncs
215 216 217 218 219 220 221 222 223

  printInfo
    (  "Processes cancelled due to termination of: "
    <> repr (fst $ snd out)
    <> " with exit information: "
    <> repr (snd $ snd out)
    <> "\n"
    )

Valentin Reis's avatar
Valentin Reis committed
224 225
  cd "../"

Valentin Reis's avatar
Valentin Reis committed
226
  return $ case snd out of
227
    (_     , Left PatternMatched) -> FoundMessage
228
    (stacki, Right (errmsg, _, _)    ) -> Died stacki errmsg
229
 where
Valentin Reis's avatar
Valentin Reis committed
230 231 232
  tupleToAsync
    :: (StackI, Instrumentation)
    -> IO (Async (StackI, Either PatternMatched (ExitCode, (), ())))
Valentin Reis's avatar
Valentin Reis committed
233
  tupleToAsync (stacki, instrum) = async $ (stacki, ) <$> runI instrum