Stack.hs 8.98 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 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
    proc "cmd"
      $   toS
Valentin Reis's avatar
Valentin Reis committed
124
      <$> ["run", "-u", cn, md <> "/manifests/" <> mn, app]
Valentin Reis's avatar
Valentin Reis committed
125
      ++  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
    for_ ([0, 1] :: [Int]) $ \x ->
Valentin Reis's avatar
Valentin Reis committed
184 185 186
      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
  runProcess (proc "mkdir" ["-p", toS wd]) >>= \case
Valentin Reis's avatar
Valentin Reis committed
190
    ExitFailure _ -> die $ "couldn't create " <> wd
Valentin Reis's avatar
Valentin Reis committed
191
    ExitSuccess   -> return ()
Valentin Reis's avatar
Valentin Reis committed
192 193 194 195

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

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

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

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

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

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

  out <- liftIO $ waitAnyCancel asyncs

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

  tracebackList <- procsWithTracebacks ilist

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

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

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

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