Stack.hs 9.36 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 40 41 42 43

import           Filesystem.Path                ( (</>) )

import           Control.Concurrent.Async

import           Argo.Utils
44 45
import           Control.Foldl                 as Fold
                                                ( length )
Valentin Reis's avatar
Valentin Reis committed
46 47 48 49
import           Control.Monad                  ( mapM_
                                                , filterM
                                                )
import           Data.Foldable                  ( for_ )
Valentin Reis's avatar
Valentin Reis committed
50
import           Data.Maybe
51 52 53
import           Data.Text                     as T
                                         hiding ( empty )
import           Data.Traversable               ( for )
Valentin Reis's avatar
Valentin Reis committed
54 55
{-import           System.Process                as P-}
                                         {-hiding ( shell )-}
Valentin Reis's avatar
Valentin Reis committed
56
import           Text.Show.Pretty
Valentin Reis's avatar
Valentin Reis committed
57 58 59 60 61 62 63 64
import           System.Process.Typed           ( readProcessStdout_
                                                , runProcess_
                                                , runProcess
                                                , proc
                                                , shell
                                                , setEnv
                                                )
import           System.Directory
Valentin Reis's avatar
Valentin Reis committed
65

Valentin Reis's avatar
Valentin Reis committed
66
cleanLeftovers :: WorkingDirectory -> IO ()
Valentin Reis's avatar
Valentin Reis committed
67
cleanLeftovers (WorkingDirectory wd) = do
Valentin Reis's avatar
Valentin Reis committed
68
  putText "Cleaning sockets."
Valentin Reis's avatar
Valentin Reis committed
69
  for_ socklist cleanSocket
Valentin Reis's avatar
Valentin Reis committed
70 71
  putText "Cleaning output directory."
  runProcess_ (shell $ toS $ "rm -rf " <> wd)
Valentin Reis's avatar
Valentin Reis committed
72 73
 where
  socklist =
Valentin Reis's avatar
Valentin Reis committed
74 75 76 77 78
    [ "/tmp/nrm-downstream-in"
    , "/tmp/nrm-downstream-event"
    , "/tmp/nrm-upstream-in"
    , "/tmp/nrm-upstream-event"
    ]
Valentin Reis's avatar
Valentin Reis committed
79 80

prepareDaemon
Valentin Reis's avatar
Valentin Reis committed
81 82 83 84
  :: StdOutLog
  -> StdErrLog
  -> Maybe TestText
  -> Verbosity
85
  -> PowerCap
Valentin Reis's avatar
Valentin Reis committed
86
  -> IO Instrumentation
87
prepareDaemon out stdErr test v powercap = do
Valentin Reis's avatar
Valentin Reis committed
88
  let confPath' = "/tmp/argo_nodeos_config"
89
  cleanContainers confPath'
90
  return $ Instrumentation
Valentin Reis's avatar
Valentin Reis committed
91 92 93 94 95 96
    (   setEnv [("ARGO_NODEOS_CONFIG", toS confPath')]
    $   proc "daemon"
    $   toS
    <$> ["--nrm_log", "./nrm_log"]
    ++  toOption v
    ++  toOption powercap
97 98 99 100
    )
    out
    stdErr
    test
Valentin Reis's avatar
Valentin Reis committed
101 102
 where
  nodeOsFailure n = do
Valentin Reis's avatar
Valentin Reis committed
103 104 105 106 107 108 109
    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 ()
110
  cleanContainers argo_nodeos_config =
Valentin Reis's avatar
Valentin Reis committed
111 112
    runProcess
        (proc "sudo" [argo_nodeos_config, "--clean_config=kill_content:true"])
113
      >>= \case
Valentin Reis's avatar
Valentin Reis committed
114 115
            ExitFailure n -> nodeOsFailure n
            ExitSuccess   -> return ()
Valentin Reis's avatar
Valentin Reis committed
116 117 118 119 120

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

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

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

cmdListenPerformanceI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPerformanceI (ContainerName cn) pb =
  Just (Performance, )
    <*> processBehaviorToI
Valentin Reis's avatar
Valentin Reis committed
156
          (proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "performance"])
Valentin Reis's avatar
Valentin Reis committed
157 158 159 160 161 162 163
          pb

cmdListenPowerI
  :: ContainerName -> ProcessBehavior -> Maybe (StackI, Instrumentation)
cmdListenPowerI (ContainerName cn) pb =
  Just (Power, )
    <*> processBehaviorToI
Valentin Reis's avatar
Valentin Reis committed
164
          (proc "cmd" ["listen", "-u", T.unpack cn, "--filter", "power"])
Valentin Reis's avatar
Valentin Reis committed
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
          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
185
runStack :: StackArgs -> IO StackOutput
186
runStack sa@StackArgs {..} = do
Valentin Reis's avatar
Valentin Reis committed
187 188
  let (WorkingDirectory wd) = workingDirectory

Valentin Reis's avatar
Style.  
Valentin Reis committed
189
  when verbose $ liftIO $ pPrint sa
Valentin Reis's avatar
Valentin Reis committed
190

191
  when (powercap /= None) $ do
Valentin Reis's avatar
Valentin Reis committed
192 193 194 195 196 197
    user <- readProcessStdout_ (proc "whoami" [])
    for_
      [0, 1]
      ( chownPowercapFiles (toS user)
      . ("/sys/devices/virtual/powercap/intel-rapl/intel-rapl:" <>)
      )
198

Valentin Reis's avatar
Valentin Reis committed
199
  cleanLeftovers workingDirectory
Valentin Reis's avatar
Valentin Reis committed
200 201 202 203

  runProcess (proc "mkdir" ["-p", toS wd]) >>= \case
    ExitFailure n -> die $ "couldn't create " <> wd
    ExitSuccess   -> return ()
Valentin Reis's avatar
Valentin Reis committed
204 205 206 207

  iDaemon <- case daemon of
    DontRun -> return Nothing
    JustRun stdOut stdErr ->
208 209
      (\i -> Just (Daemon, i))
        <$> prepareDaemon stdOut stdErr Nothing verbosity powercap
Valentin Reis's avatar
Valentin Reis committed
210
    Test t stdOut stdErr ->
211 212
      (\i -> Just (Daemon, i))
        <$> prepareDaemon stdOut stdErr (Just t) Verbose powercap
Valentin Reis's avatar
Valentin Reis committed
213

Valentin Reis's avatar
Valentin Reis committed
214 215
  let milist :: [Maybe (StackI, Instrumentation)]
      milist =
Valentin Reis's avatar
Valentin Reis committed
216
        [ iDaemon
217
        , cmdRunI app args containerName shareDir manifestName vars cmdrun
Valentin Reis's avatar
Valentin Reis committed
218 219 220 221 222 223 224
        , cmdListenI containerName cmdlisten
        , cmdListenPerformanceI containerName cmdlistenperformance
        , cmdListenProgressI containerName cmdlistenprogress
        , cmdListenPowerI containerName cmdlistenpower
        ]
      ilist = catMaybes milist

Valentin Reis's avatar
Valentin Reis committed
225
  _ <- shell (coerce preludeCommand :: Text) empty >>= \case
Valentin Reis's avatar
Valentin Reis committed
226 227
    ExitSuccess ->
      when verbose $ putText ("Executed preludeCommand." <> repr preludeCommand)
Valentin Reis's avatar
Valentin Reis committed
228 229
    ExitFailure _ ->
      die ("failed to execute preludeCommand." <> repr preludeCommand)
Valentin Reis's avatar
Valentin Reis committed
230

Valentin Reis's avatar
Style.  
Valentin Reis committed
231
  when verbose $ do
Valentin Reis's avatar
Valentin Reis committed
232
    putText "Starting the following processes:"
Valentin Reis's avatar
Style.  
Valentin Reis committed
233
    liftIO $ pPrint ilist
Valentin Reis's avatar
Valentin Reis committed
234

Valentin Reis's avatar
Valentin Reis committed
235 236
  asyncs <- liftIO $ for ilist tupleToAsync
  _      <- liftIO $ kbInstallHandler $ for_ asyncs cancel
Valentin Reis's avatar
Valentin Reis committed
237

Valentin Reis's avatar
Valentin Reis committed
238
  when verbose $ putText "Processes started."
Valentin Reis's avatar
Valentin Reis committed
239 240 241

  out <- liftIO $ waitAnyCancel asyncs

Valentin Reis's avatar
Valentin Reis committed
242
  putText
Valentin Reis's avatar
Valentin Reis committed
243 244 245 246 247 248 249 250
    (  "Processes cancelled due to termination of: "
    <> repr (fst $ snd out)
    <> " with exit information: "
    <> repr (snd $ snd out)
    )

  tracebackList <- procsWithTracebacks ilist

Valentin Reis's avatar
Valentin Reis committed
251
  r             <- case snd out of
Valentin Reis's avatar
Valentin Reis committed
252 253 254 255 256 257 258 259 260 261 262 263 264
    (_, 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

  cd "../"
  return r
 where
265 266 267
  chownPowercap user fn =
    shell (format ("sudo chown " % s % ":" % s % " " % s) user user fn) empty
      >>= \case
Valentin Reis's avatar
Valentin Reis committed
268 269
            ExitSuccess   -> printWarning $ "changed ownership on " <> fn
            ExitFailure _ -> die $ "Couldn't change ownership on " <> fn
270

Valentin Reis's avatar
Valentin Reis committed
271
  chownPowercapFiles :: Text -> Text -> IO ()
272 273 274 275
  chownPowercapFiles user p =
    chownPowercap user (p <> "/constraint_1_power_limit_uw")
      <> chownPowercap user (p <> "/constraint_0_power_limit_uw")

276
  verbose = verbosity == Verbose
Valentin Reis's avatar
Valentin Reis committed
277
  procsWithTracebacks
Valentin Reis's avatar
Valentin Reis committed
278
    :: [(StackI, Instrumentation)] -> IO [(StackI, Text, Text)]
Valentin Reis's avatar
Valentin Reis committed
279 280 281 282 283 284
  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
285 286 287 288
  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
289 290 291 292 293 294 295 296 297 298 299

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