Stack.hs 9.04 KB
Newer Older
Valentin Reis's avatar
Style.  
Valentin Reis committed
1
{-# language TupleSections #-}
Valentin Reis's avatar
Valentin Reis committed
2
{-# language FlexibleContexts #-}
Valentin Reis's avatar
Style.  
Valentin Reis committed
3 4
{-# language LambdaCase #-}
{-# language RecordWildCards #-}
Valentin Reis's avatar
Valentin Reis committed
5
{-# language NoImplicitPrelude #-}
Valentin Reis's avatar
Style.  
Valentin Reis committed
6
{-# language OverloadedStrings #-}
Valentin Reis's avatar
Valentin Reis committed
7

Valentin Reis's avatar
Valentin Reis committed
8 9 10 11 12 13 14 15
{-|
Module      : Argo.Stack
Description : Argo stack library
Copyright   : (c) Valentin Reis, 2018
License     : MIT
Maintainer  : fre@freux.fr
-}

16
module Argo.Stack
17 18 19 20 21 22 23 24 25 26 27 28
  ( cleanLeftovers
  , prepareDaemon
  , cmdRunI
  , cmdListenI
  , cmdListenProgressI
  , cmdListenPerformanceI
  , cmdListenPowerI
  , StackOutput(..)
  , Tracebacks
  , TracebackScanOut(..)
  , TracebackScanErr(..)
  , StackI(..)
29 30 31 32
  , runStack
  )
where

33
import           Argo.Types
Valentin Reis's avatar
Valentin Reis committed
34 35
import qualified Prelude                        ( show )
import           Protolude
Valentin Reis's avatar
Valentin Reis committed
36

Valentin Reis's avatar
Valentin Reis committed
37
import           Data.Coerce                    ( coerce )
Valentin Reis's avatar
Valentin Reis committed
38 39

import           Argo.Utils
Valentin Reis's avatar
Valentin Reis committed
40
import           Data.Foldable                  ( for_ )
41 42 43
import           Data.Text                     as T
                                         hiding ( empty )
import           Data.Traversable               ( for )
Valentin Reis's avatar
Valentin Reis committed
44
import           System.Directory
Valentin Reis's avatar
Valentin Reis committed
45 46 47 48 49 50 51
import           System.Process.Typed           ( readProcessStdout_
                                                , runProcess_
                                                , runProcess
                                                , proc
                                                , shell
                                                , setEnv
                                                )
Valentin Reis's avatar
Valentin Reis committed
52
import           Text.Show.Pretty
Valentin Reis's avatar
Valentin Reis committed
53

Valentin Reis's avatar
Valentin Reis committed
54
cleanLeftovers :: WorkingDirectory -> IO ()
Valentin Reis's avatar
Valentin Reis committed
55
cleanLeftovers (WorkingDirectory wd) = do
Valentin Reis's avatar
Valentin Reis committed
56
  putText "Cleaning sockets."
Valentin Reis's avatar
Valentin Reis committed
57
  for_ socklist cleanSocket
Valentin Reis's avatar
Valentin Reis committed
58 59
  putText "Cleaning output directory."
  runProcess_ (shell $ toS $ "rm -rf " <> wd)
Valentin Reis's avatar
Valentin Reis committed
60 61
 where
  socklist =
Valentin Reis's avatar
Valentin Reis committed
62 63 64 65 66
    [ "/tmp/nrm-downstream-in"
    , "/tmp/nrm-downstream-event"
    , "/tmp/nrm-upstream-in"
    , "/tmp/nrm-upstream-event"
    ]
Valentin Reis's avatar
Valentin Reis committed
67 68

prepareDaemon
Valentin Reis's avatar
Valentin Reis committed
69 70 71 72
  :: StdOutLog
  -> StdErrLog
  -> Maybe TestText
  -> Verbosity
73
  -> PowerCap
Valentin Reis's avatar
Valentin Reis committed
74
  -> [(EnvVar, Text)]
Valentin Reis's avatar
Valentin Reis committed
75
  -> IO Instrumentation
Valentin Reis's avatar
Valentin Reis committed
76
prepareDaemon out stdErr test v powercap vars = do
Valentin Reis's avatar
Valentin Reis committed
77
  let confPath' = "/tmp/argo_nodeos_config"
78
  cleanContainers confPath'
79
  return $ Instrumentation
Valentin Reis's avatar
Valentin Reis committed
80
    (   setEnv ((castArg <$> vars) ++ [("ARGO_NODEOS_CONFIG", toS confPath')])
Valentin Reis's avatar
Valentin Reis committed
81 82 83 84 85
    $   proc "daemon"
    $   toS
    <$> ["--nrm_log", "./nrm_log"]
    ++  toOption v
    ++  toOption powercap
86 87 88 89
    )
    out
    stdErr
    test
Valentin Reis's avatar
Valentin Reis committed
90
 where
Valentin Reis's avatar
Valentin Reis committed
91
  castArg (EnvVar varname, y) = (toS varname, toS y)
Valentin Reis's avatar
Valentin Reis committed
92
  nodeOsFailure n = do
Valentin Reis's avatar
Valentin Reis committed
93 94 95 96 97 98 99
    printError $ "argo_nodeos_config failed with exit code :" <> show n
    doesFileExist ".argo_nodeos_config_exit_message" >>= \case
      True ->
        putText "Contents of .argo_nodeos_config_exit_message: "
          *> (readFile ".argo_nodeos_config_exit_message" >>= print)
      False -> die ("argo_nodeos_config failed with exit code " <> show n)
  cleanContainers :: FilePath -> IO ()
100
  cleanContainers argo_nodeos_config =
Valentin Reis's avatar
Valentin Reis committed
101
    runProcess
Valentin Reis's avatar
Valentin Reis committed
102 103 104 105
        (setEnv (castArg <$> vars) $ proc
          "sudo"
          [argo_nodeos_config, "--clean_config=kill_content:true"]
        )
106
      >>= \case
Valentin Reis's avatar
Valentin Reis committed
107 108
            ExitFailure n -> nodeOsFailure n
            ExitSuccess   -> return ()
Valentin Reis's avatar
Valentin Reis committed
109 110 111 112 113

cmdRunI
  :: AppName
  -> [AppArg]
  -> ContainerName
Valentin Reis's avatar
adding  
Valentin Reis committed
114
  -> ShareDir
Valentin Reis's avatar
Valentin Reis committed
115
  -> ManifestName
116
  -> [(EnvVar, Text)]
Valentin Reis's avatar
Valentin Reis committed
117 118
  -> ProcessBehavior
  -> Maybe (StackI, Instrumentation)
119
cmdRunI (AppName app) args (ContainerName cn) (ShareDir md) (ManifestName mn) vars pb
Valentin Reis's avatar
Valentin Reis committed
120
  = Just (Run, ) <*> processBehaviorToI (setEnv (castArg <$> vars) pp) pb
121 122
 where
  argToText (AppArg a) = a
Valentin Reis's avatar
Valentin Reis committed
123
  castArg (EnvVar v, y) = (toS v, toS y)
124
  pp =
Valentin Reis's avatar
Valentin Reis committed
125 126
    proc "cmd"
      $   toS
Valentin Reis's avatar
Valentin Reis committed
127
      <$> ["run", "-u", cn, md <> "/manifests/" <> mn, app]
Valentin Reis's avatar
Valentin Reis committed
128
      ++  fmap argToText args
Valentin Reis's avatar
Valentin Reis committed
129 130 131 132 133

cmdListenI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenI (ContainerName cn) pb =
  Just (Listen, )
Valentin Reis's avatar
Valentin Reis committed
134
    <*> processBehaviorToI (proc "cmd" ["listen", "-u", T.unpack cn]) pb
Valentin Reis's avatar
Valentin Reis committed
135 136 137 138 139 140

cmdListenProgressI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenProgressI (ContainerName cn) pb =
  Just (Progress, )
    <*> processBehaviorToI
Valentin Reis's avatar
Valentin Reis committed
141
          (proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "progress"])
Valentin Reis's avatar
Valentin Reis committed
142 143 144 145 146 147 148
          pb

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

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

data StackOutput =
    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)

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
178
runStack :: StackArgs -> IO StackOutput
179
runStack sa@StackArgs {..} = do
Valentin Reis's avatar
Valentin Reis committed
180 181
  let (WorkingDirectory wd) = workingDirectory

Valentin Reis's avatar
Style.  
Valentin Reis committed
182
  when verbose $ liftIO $ pPrint sa
Valentin Reis's avatar
Valentin Reis committed
183

184
  when (powercap /= None) $ do
Valentin Reis's avatar
Valentin Reis committed
185
    user <- readProcessStdout_ (proc "whoami" [])
Valentin Reis's avatar
Valentin Reis committed
186
    for_ ([0, 1] :: [Int]) $ \x ->
Valentin Reis's avatar
Valentin Reis committed
187 188 189
      chownPowercapFiles (toS user)
        $  "/sys/devices/virtual/powercap/intel-rapl/intel-rapl:"
        <> show x
190

Valentin Reis's avatar
Valentin Reis committed
191
  cleanLeftovers workingDirectory
Valentin Reis's avatar
Valentin Reis committed
192
  runProcess (proc "mkdir" ["-p", toS wd]) >>= \case
Valentin Reis's avatar
Valentin Reis committed
193
    ExitFailure _ -> die $ "couldn't create " <> wd
Valentin Reis's avatar
Valentin Reis committed
194
    ExitSuccess   -> return ()
Valentin Reis's avatar
Valentin Reis committed
195 196 197 198

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

Valentin Reis's avatar
Valentin Reis committed
205 206
  let milist :: [Maybe (StackI, Instrumentation)]
      milist =
Valentin Reis's avatar
Valentin Reis committed
207
        [ iDaemon
208
        , cmdRunI app args containerName shareDir manifestName vars cmdrun
Valentin Reis's avatar
Valentin Reis committed
209 210 211 212 213 214 215
        , cmdListenI containerName cmdlisten
        , cmdListenPerformanceI containerName cmdlistenperformance
        , cmdListenProgressI containerName cmdlistenprogress
        , cmdListenPowerI containerName cmdlistenpower
        ]
      ilist = catMaybes milist

Valentin Reis's avatar
Valentin Reis committed
216 217 218 219 220
  _ <- runProcess (shell $ toS (coerce preludeCommand :: Text)) >>= \case
    ExitSuccess -> when verbose $ putText
      ("Executed preludeCommand." <> toS (coerce preludeCommand :: Text))
    ExitFailure _ -> die $ "failed to execute preludeCommand." <> toS
      (coerce preludeCommand :: Text)
Valentin Reis's avatar
Valentin Reis committed
221

Valentin Reis's avatar
Style.  
Valentin Reis committed
222
  when verbose $ do
Valentin Reis's avatar
Valentin Reis committed
223
    putText "Starting the following processes:"
Valentin Reis's avatar
Style.  
Valentin Reis committed
224
    liftIO $ pPrint ilist
Valentin Reis's avatar
Valentin Reis committed
225

Valentin Reis's avatar
Valentin Reis committed
226 227
  asyncs <- liftIO $ for ilist tupleToAsync
  _      <- liftIO $ kbInstallHandler $ for_ asyncs cancel
Valentin Reis's avatar
Valentin Reis committed
228

Valentin Reis's avatar
Valentin Reis committed
229
  when verbose $ putText "Processes started."
Valentin Reis's avatar
Valentin Reis committed
230 231 232

  out <- liftIO $ waitAnyCancel asyncs

Valentin Reis's avatar
Valentin Reis committed
233
  putText
Valentin Reis's avatar
Valentin Reis committed
234
    (  "Processes cancelled due to termination of: "
Valentin Reis's avatar
Valentin Reis committed
235
    <> show (fst $ snd out)
Valentin Reis's avatar
Valentin Reis committed
236
    <> " with exit information: "
Valentin Reis's avatar
Valentin Reis committed
237
    <> show (snd $ snd out)
Valentin Reis's avatar
Valentin Reis committed
238 239 240 241
    )

  tracebackList <- procsWithTracebacks ilist

Valentin Reis's avatar
Valentin Reis committed
242
  case snd out of
Valentin Reis's avatar
Valentin Reis committed
243 244 245 246 247 248 249 250 251 252
    (_, 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
 where
253
  chownPowercap user fn =
Valentin Reis's avatar
Valentin Reis committed
254
    runProcess (shell $ toS ("sudo chown " <> user <> ":" <> user <> " " <> fn))
255
      >>= \case
Valentin Reis's avatar
Valentin Reis committed
256 257
            ExitSuccess   -> printWarning $ "changed ownership on " <> fn
            ExitFailure _ -> die $ "Couldn't change ownership on " <> fn
258

Valentin Reis's avatar
Valentin Reis committed
259
  chownPowercapFiles :: Text -> Text -> IO ()
260 261 262 263
  chownPowercapFiles user p =
    chownPowercap user (p <> "/constraint_1_power_limit_uw")
      <> chownPowercap user (p <> "/constraint_0_power_limit_uw")

264
  verbose = verbosity == Verbose
Valentin Reis's avatar
Valentin Reis committed
265
  procsWithTracebacks
Valentin Reis's avatar
Valentin Reis committed
266
    :: [(StackI, Instrumentation)] -> IO [(StackI, Text, Text)]
Valentin Reis's avatar
Valentin Reis committed
267 268 269 270 271 272
  procsWithTracebacks ilist = fmap showOutputs <$> filterM (checkI . snd) ilist

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

Valentin Reis's avatar
Valentin Reis committed
273 274 275 276
  checkI :: Instrumentation -> IO Bool
  checkI (Instrumentation _ (StdOutLog outlog) (StdErrLog errlog) _) =
    return $ test outlog || test errlog
    where test = isInfixOf "Traceback"
Valentin Reis's avatar
Valentin Reis committed
277 278 279 280 281 282 283 284 285 286 287

  tupleToAsync
    :: (StackI, Instrumentation)
    -> IO
         ( Async
             ( StackI
             , Either
                 MonitoringResult
                 (ExitCode, TracebackScan, TracebackScan)
             )
         )
Valentin Reis's avatar
Valentin Reis committed
288 289
  tupleToAsync (stacki, instrum) =
    async $ (stacki, ) <$> runI workingDirectory instrum