Stack.hs 9.49 KB
Newer Older
1
{-# LANGUAGE
Valentin Reis's avatar
Valentin Reis committed
2
  TupleSections,
3 4
  LambdaCase,
  RecordWildCards,
5
  OverloadedStrings #-}
6 7

module Argo.Stack where
8
import           Argo.Args
9 10

import           Turtle
11
import           Turtle.Shell
12 13 14
import           Prelude                 hiding ( FilePath )

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

16
import           Control.Concurrent.Async
17

18
import           Data.Text                     as T
19 20
                                         hiding ( empty )
import           Argo.Utils
21 22
import           System.Process                as P
                                         hiding ( shell )
23 24
import           Control.Monad                 as CM
import           Data.Maybe
25
import           Control.Foldl                 as Fold
26
import           Text.Show.Pretty
27

Valentin Reis's avatar
Valentin Reis committed
28 29
cleanLeftovers :: WorkingDirectory -> Shell ()
cleanLeftovers (WorkingDirectory wd) = do
30
  printInfo "Cleaning working(output) directory."
Valentin Reis's avatar
Valentin Reis committed
31
  cleanLog wd
32
  printInfo "Cleaning sockets."
33
  CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
34

Valentin Reis's avatar
Valentin Reis committed
35 36
checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do
37 38 39 40
  let dir = case toText workingDirectory of
        Left  di -> di
        Right di -> di
  let findmnt = inproc "findmnt" ["-T", dir, "-o", "OPTIONS"] empty
41 42 43 44 45
  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
46
prepareDaemon
47
  :: StdOutLog -> StdErrLog -> Maybe TestText -> Shell Instrumentation
48
prepareDaemon out stdErr test = do
49
  _        <- myWhich "daemon"
50 51
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
52
  cp confPath confPath'
53
  printInfo $ format ("Copied the configurator to " % fp) confPath'
54
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config"
55
  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
56
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root."
57 58
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
59
  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
60
    ExitSuccess   -> printInfo "Set the suid bit."
61
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
62
  cleanContainers confPath' 1 2
63
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
64
  return $ Instrumentation (P.proc "daemon" []) out stdErr test
65
 where
66
  nodeOsFailure n = do
67
    printError ("argo_nodeos_config failed with exit code :" <> repr n)
68 69
    testfile ".argo_nodeos_config_exit_message" >>= \case
      True -> do
70
        printInfo "Contents of .argo_nodeos_config_exit_message: "
71
        view $ input ".argo_nodeos_config_exit_message"
72
      False -> die ("argo_nodeos_config failed with exit code " <> repr n)
73
  cleanContainers :: FilePath -> NominalDiffTime -> Integer -> Shell ()
74
  cleanContainers argo_nodeos_config retryTime remainingRetries = do
75 76
    let showConfig =
          inshell (format (fp % " --show_config") argo_nodeos_config) empty
77 78 79 80
    verboseShell'
        (format (fp % " --clean_config=kill_content:true") argo_nodeos_config)
        empty
      >>= \case
81 82
            (ExitFailure n, _, _) -> do
              when (remainingRetries == 0) $ nodeOsFailure n
83 84 85
              printWarning
                (  "the argo_nodeos_config call failed with exit code "
                <> repr n
86
                <> ". Retrying.."
87 88 89 90 91 92
                )
              liftIO $ sleep (retryTime * 2)
              cleanContainers argo_nodeos_config
                              (retryTime * 2)
                              (remainingRetries - 1)
            (ExitSuccess, _, _) -> do
93
              printInfo "Cleaned the argo config."
94
              len <- liftIO $ Turtle.Shell.fold
95 96
                (grep (has "CONTAINER") showConfig)
                Fold.length
97
              if len > 0
98 99 100 101 102 103 104 105 106 107 108
                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 \
109
                    \config."
110

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

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

143 144 145 146 147 148 149 150 151
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
152 153 154 155 156 157 158 159 160
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 =
161 162 163 164 165 166
    FoundMessage Text
  | FoundTracebacks Tracebacks
  | Died StackI ExitCode TracebackScanOut TracebackScanErr Tracebacks deriving (Show)
type Tracebacks = [(StackI, Text, Text)]
newtype TracebackScanOut = TracebackScanOut TracebackScan deriving (Show)
newtype TracebackScanErr = TracebackScanErr TracebackScan deriving (Show)
Valentin Reis's avatar
Valentin Reis committed
167

168 169 170 171 172 173 174 175 176
data StackI = Daemon | Run | Listen | Progress | Power | Performance deriving (Eq)
instance Show StackI where
  show = \case
    Daemon -> "daemon"
    Run -> "cmd run"
    Listen -> "cmd listen -v"
    Progress -> "cmd listen -f progress"
    Power -> "cmd listen -f power"
    Performance -> "cmd listen -f performance"
Valentin Reis's avatar
Valentin Reis committed
177

178
runStack :: StackArgs -> Shell StackOutput
179 180 181
runStack sa@StackArgs {..} = do
  when (verbosity == Verbose) $ liftIO $ pPrint sa

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

  iDaemon <- case daemon of
    DontRun -> return Nothing
196 197
    JustRun stdOut stdErr ->
      (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr Nothing
198
    Test t stdOut stdErr ->
199
      (\i -> Just (Daemon, i)) <$> prepareDaemon stdOut stdErr (Just t)
Valentin Reis's avatar
Valentin Reis committed
200 201 202 203 204

  let milist =
        [ iDaemon
        , cmdRunI app args containerName manifestDir manifestName cmdrun
        , cmdListenI containerName cmdlisten
205
        , cmdListenPerformanceI containerName cmdlistenperformance
Valentin Reis's avatar
Valentin Reis committed
206 207 208 209 210
        , cmdListenProgressI containerName cmdlistenprogress
        , cmdListenPowerI containerName cmdlistenpower
        ]
      ilist = catMaybes milist

211 212
  if verbosity == Verbose
    then do
213
      printInfo "Starting the following processes:"
214 215 216
      liftIO $ pPrint ilist
    else liftIO $ pPrint (fmap fst ilist)

Valentin Reis's avatar
Valentin Reis committed
217
  asyncs <- liftIO $ mapM tupleToAsync ilist
218
  _      <- liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
219

220
  when (verbosity == Verbose) $ printInfo "Processes started."
221

Valentin Reis's avatar
Valentin Reis committed
222
  out <- liftIO $ waitAnyCancel asyncs
223 224 225 226 227 228 229 230

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

231 232 233 234 235 236 237 238 239 240 241 242 243
  tracebackList <- procsWithTracebacks ilist

  r <- case snd out of
    (_, Left (PatternMatched line)) -> case tracebackList of
      [] -> return $ FoundMessage line
      t  -> return $ FoundTracebacks t
    (stacki, Right (errmsg, tracebackOut, tracebackErr)) -> return $ Died
      stacki
      errmsg
      (TracebackScanOut tracebackOut)
      (TracebackScanErr tracebackErr)
      tracebackList

Valentin Reis's avatar
Valentin Reis committed
244 245
  cd "../"

246
  return r
247
 where
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
  procsWithTracebacks
    :: [(StackI, Instrumentation)] -> Shell [(StackI, Text, Text)]
  procsWithTracebacks ilist = fmap showOutputs <$> filterM (checkI . snd) ilist

  showOutputs :: (StackI, Instrumentation) -> (StackI, Text, Text)
  showOutputs (si, Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) =
    (si, outlog, errlog)

  checkI :: Instrumentation -> Shell Bool
  checkI (Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) = do
    b <- liftIO $ Turtle.Shell.fold
      (grep (has "Traceback") (input $ fromText outlog))
      Fold.length
    c <- liftIO $ Turtle.Shell.fold
      (grep (has "Traceback") (input $ fromText errlog))
      Fold.length
    return $ (b > 0) || (c > 0)

Valentin Reis's avatar
Valentin Reis committed
266 267
  tupleToAsync
    :: (StackI, Instrumentation)
268 269 270 271 272 273 274 275
    -> IO
         ( Async
             ( StackI
             , Either
                 MonitoringResult
                 (ExitCode, TracebackScan, TracebackScan)
             )
         )
276
  tupleToAsync (stacki, instrum) = async $ (stacki, ) <$> runI instrum