Stack.hs 8.08 KB
Newer Older
1
{-# LANGUAGE
Valentin Reis's avatar
Valentin Reis committed
2
  TupleSections,
3
  ScopedTypeVariables,
4 5 6 7 8 9 10
  LambdaCase,
  RecordWildCards,
  OverloadedStrings,
  DataKinds,
  FlexibleInstances,
  TypeOperators,
  ApplicativeDo #-}
11 12

module Argo.Stack where
13
import           Argo.Args
14 15

import           Turtle
16
import           Turtle.Shell
17 18 19 20 21
import           Prelude                 hiding ( FilePath )

import           System.IO                      ( withFile )
import           Debug.Trace
import           Filesystem.Path                ( (</>) )
22

23
import           Control.Concurrent.Async
24 25 26 27
import           Control.Monad.STM              ( atomically
                                                , orElse
                                                )

28
import           System.Console.ANSI
29
import           System.Console.ANSI.Types      ( Color )
30
import           Data.Text                     as T
31 32 33
                                         hiding ( empty )
import           Data.Text.IO                  as Text
import           Argo.Utils
34 35
import           System.Process                as P
                                         hiding ( shell )
36
import           Options.Applicative           as OA
37
import           Control.Monad.Extra           as E
38 39 40 41 42 43 44 45
import           Control.Monad                 as CM
import           Control.Foldl                 as F
import           Data.Conduit
import           Data.Conduit.Process
import           Data.ByteString.Char8         as C8
                                         hiding ( empty )
import           Control.Exception.Base
import           Data.Maybe
46
import           Control.Foldl                 as Fold
47

Valentin Reis's avatar
Valentin Reis committed
48 49
cleanLeftovers :: WorkingDirectory -> Shell ()
cleanLeftovers (WorkingDirectory wd) = do
50
  printInfo "Cleaning leftover files.\n"
Valentin Reis's avatar
Valentin Reis committed
51
  cleanLog wd
52
  printInfo "Cleaning leftover sockets.\n"
53
  CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
54

Valentin Reis's avatar
Valentin Reis committed
55 56
checkFsAttributes :: FilePath -> Shell ()
checkFsAttributes workingDirectory = do
57 58 59 60 61 62 63 64 65
  let x = case toText workingDirectory of
        Left  x -> x
        Right x -> x
  let findmnt = inproc "findmnt" ["-T", x, "-o", "OPTIONS"] empty
  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
66 67 68 69 70 71 72 73 74 75
prepareDaemon
  :: StdOutLog
  -> StdErrLog
  -> Maybe TestText
  -> WorkingDirectory
  -> Shell Instrumentation
prepareDaemon (StdOutLog out) (StdErrLog err) test (WorkingDirectory wd) = do
  mktree wd
  checkFsAttributes wd
  cd wd
76
  myWhich "daemon"
77 78
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
79 80 81
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
82
  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
83 84 85
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
86
  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
87 88
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
89
  cleanContainers confPath' 1 2
90
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
Valentin Reis's avatar
Valentin Reis committed
91 92 93 94
  return $ Instrumentation (P.proc "daemon" [])
                           (StdOutLog out)
                           (StdErrLog err)
                           test
95 96 97 98 99 100
 where
  nodeOsFailure (ExitFailure n, _, _) = do
    printError ("argo_nodeos_config failed with exit code :" <> repr n <> "\n")
    testfile ".argo_nodeos_config_exit_message" >>= \case
      True -> do
        printInfo "Contents of .argo_nodeos_config_exit_message: \n"
101
        view $ input ".argo_nodeos_config_exit_message"
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
      False -> die ("argo_nodeos_config failed with exit code " <> repr n)
  cleanContainers argo_nodeos_config retryTime remainingRetries = do
    let
      showConfig =
        inshell (format (fp % " --show_config") argo_nodeos_config) empty
      (isClean :: IO Bool) =
        liftIO
            (Turtle.Shell.fold (grep (has "CONTAINER") showConfig) Fold.length)
          >>= (\x -> return $ x > 5)
    verboseShell'
        (format (fp % " --clean_config=kill_content:true") argo_nodeos_config)
        empty
      >>= \case
            e@(ExitFailure n, out, err) -> do
              when (remainingRetries == 0) $ nodeOsFailure e
              printWarning
                (  "the argo_nodeos_config call failed with exit code "
                <> repr n
                <> ". Retrying..\n"
                )
              liftIO $ sleep (retryTime * 2)
              cleanContainers argo_nodeos_config
                              (retryTime * 2)
                              (remainingRetries - 1)
            (ExitSuccess, _, _) -> do
              printInfo "Cleaned the argo config.\n"
              l <- liftIO $ Turtle.Shell.fold
                (grep (has "CONTAINER") showConfig)
                Fold.length
              if l > 0
                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 \
                \config."
144

Valentin Reis's avatar
Valentin Reis committed
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
cmdRunI
  :: AppName
  -> AppArgs
  -> ContainerName
  -> ManifestDir
  -> ManifestName
  -> ProcessBehavior
  -> Maybe (StackI, Instrumentation)
cmdRunI (AppName app) (AppArgs args) (ContainerName cn) (ManifestDir md) (ManifestName mn) pb
  = Just (Run, )
    <*> processBehaviorToI
          (  P.proc "cmd"
          $  ["run", "-u", T.unpack cn, encodeString $ md </> mn, T.unpack app]
          ++ fmap T.unpack args
          )
          pb

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

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 =
    FoundMessage
  | MessageNotFound
  | Died StackI ExitCode

data StackI = Daemon | Run | Listen | Progress | Power deriving (Show)

runListenStack :: StackArgs -> Shell StackOutput
192
runListenStack a@StackArgs {..} = do
Valentin Reis's avatar
Valentin Reis committed
193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
  cleanLeftovers workingDirectory

  iDaemon <- case daemon of
    DontRun -> return Nothing
    JustRun out err ->
      (\x -> Just (Daemon, x))
        <$> prepareDaemon out err Nothing workingDirectory
    SucceedTestOnMessage t out err ->
      (\x -> Just (Daemon, x))
        <$> prepareDaemon out err (Just t) workingDirectory

  let milist =
        [ iDaemon
        , cmdRunI app args containerName manifestDir manifestName cmdrun
        , cmdListenI containerName cmdlisten
        , cmdListenProgressI containerName cmdlistenprogress
        , cmdListenPowerI containerName cmdlistenpower
        ]
      ilist = catMaybes milist

  asyncs <- liftIO $ mapM tupleToAsync ilist
  liftIO $ kbInstallHandler $ CM.mapM_ cancel asyncs
  out <- liftIO $ waitAnyCancel asyncs
  return $ case snd out of
    (_     , Left PatternMatched      ) -> FoundMessage
    (Run   , Right (ExitSuccess, _, _)) -> MessageNotFound
    (stacki, Right (e, _, _)          ) -> Died stacki e
220
 where
Valentin Reis's avatar
Valentin Reis committed
221 222 223 224
  tupleToAsync
    :: (StackI, Instrumentation)
    -> IO (Async (StackI, Either PatternMatched (ExitCode, (), ())))
  tupleToAsync (stacki, instrum) = async $ (stacki,) <$> runI instrum