Stack.hs 8.04 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
Valentin Reis's avatar
Valentin Reis committed
173 174 175
runStack sa@StackArgs {..} = do
  when (verbosity == Verbose) $ liftIO $ pPrint sa

176 177 178 179 180 181
  CM.mapM_
    cleanSocket
    [ "/tmp/nrm-downstream-in"
    , "/tmp/nrm-upstream-in"
    , "/tmp/nrm-upstream-event"
    ]
Valentin Reis's avatar
Valentin Reis committed
182
  let (WorkingDirectory wd) = workingDirectory
183
  _ <- Turtle.shell (format ("rm -rf " % fp) wd) Turtle.empty
Valentin Reis's avatar
Valentin Reis committed
184 185 186
  mktree wd
  checkFsAttributes wd
  cd wd
Valentin Reis's avatar
Valentin Reis committed
187 188 189

  iDaemon <- case daemon of
    DontRun -> return Nothing
190 191 192 193
    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
194 195 196 197 198

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

205 206 207 208 209 210
  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
211
  asyncs <- liftIO $ mapM tupleToAsync ilist
212
  _ <- liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
213 214 215

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

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

  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
226 227
  cd "../"

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