Stack.hs 8.99 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

Valentin Reis's avatar
Valentin Reis committed
33 34
import           Protolude
import qualified Prelude                        ( show )
35
import           Argo.Types
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 45
{-import           System.Process                as P-}
                                         {-hiding ( shell )-}
Valentin Reis's avatar
Valentin Reis committed
46
import           Text.Show.Pretty
Valentin Reis's avatar
Valentin Reis committed
47 48 49 50 51 52 53 54
import           System.Process.Typed           ( readProcessStdout_
                                                , runProcess_
                                                , runProcess
                                                , proc
                                                , shell
                                                , setEnv
                                                )
import           System.Directory
Valentin Reis's avatar
Valentin Reis committed
55

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

prepareDaemon
Valentin Reis's avatar
Valentin Reis committed
71 72 73 74
  :: StdOutLog
  -> StdErrLog
  -> Maybe TestText
  -> Verbosity
75
  -> PowerCap
Valentin Reis's avatar
Valentin Reis committed
76
  -> IO Instrumentation
77
prepareDaemon out stdErr test v powercap = do
Valentin Reis's avatar
Valentin Reis committed
78
  let confPath' = "/tmp/argo_nodeos_config"
79
  cleanContainers confPath'
80
  return $ Instrumentation
Valentin Reis's avatar
Valentin Reis committed
81 82 83 84 85 86
    (   setEnv [("ARGO_NODEOS_CONFIG", toS confPath')]
    $   proc "daemon"
    $   toS
    <$> ["--nrm_log", "./nrm_log"]
    ++  toOption v
    ++  toOption powercap
87 88 89 90
    )
    out
    stdErr
    test
Valentin Reis's avatar
Valentin Reis committed
91 92
 where
  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 102
    runProcess
        (proc "sudo" [argo_nodeos_config, "--clean_config=kill_content:true"])
103
      >>= \case
Valentin Reis's avatar
Valentin Reis committed
104 105
            ExitFailure n -> nodeOsFailure n
            ExitSuccess   -> return ()
Valentin Reis's avatar
Valentin Reis committed
106 107 108 109 110

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

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

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

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

cmdListenPowerI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPowerI (ContainerName cn) pb =
  Just (Power, )
    <*> processBehaviorToI
Valentin Reis's avatar
Valentin Reis committed
154
          (proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
Valentin Reis's avatar
Valentin Reis committed
155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
          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
175
runStack :: StackArgs -> IO StackOutput
176
runStack sa@StackArgs {..} = do
Valentin Reis's avatar
Valentin Reis committed
177 178
  let (WorkingDirectory wd) = workingDirectory

Valentin Reis's avatar
Style.  
Valentin Reis committed
179
  when verbose $ liftIO $ pPrint sa
Valentin Reis's avatar
Valentin Reis committed
180

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

Valentin Reis's avatar
Valentin Reis committed
188
  cleanLeftovers workingDirectory
Valentin Reis's avatar
Valentin Reis committed
189 190

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

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

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

Valentin Reis's avatar
Valentin Reis committed
214 215 216 217 218
  _ <- 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
219

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

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

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

  out <- liftIO $ waitAnyCancel asyncs

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

  tracebackList <- procsWithTracebacks ilist

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

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

262
  verbose = verbosity == Verbose
Valentin Reis's avatar
Valentin Reis committed
263
  procsWithTracebacks
Valentin Reis's avatar
Valentin Reis committed
264
    :: [(StackI, Instrumentation)] -> IO [(StackI, Text, Text)]
Valentin Reis's avatar
Valentin Reis committed
265 266 267 268 269 270
  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
271 272 273 274
  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
275 276 277 278 279 280 281 282 283 284 285

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