Stack.hs 9.72 KB
Newer Older
1 2
{-# LANGUAGE
  ScopedTypeVariables,
3 4 5 6 7 8 9
  LambdaCase,
  RecordWildCards,
  OverloadedStrings,
  DataKinds,
  FlexibleInstances,
  TypeOperators,
  ApplicativeDo #-}
10 11

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

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

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

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

27
import           System.Console.ANSI
28
import           System.Console.ANSI.Types      ( Color )
29
import           Data.Text                     as T
30 31 32
                                         hiding ( empty )
import           Data.Text.IO                  as Text
import           Argo.Utils
33 34
import           System.Process                as P
                                         hiding ( shell )
35
import           Options.Applicative           as OA
36
import           Control.Monad.Extra           as E
37 38 39 40 41 42 43 44
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
45
import           Control.Foldl                 as Fold
46

47

48 49 50 51 52 53 54 55 56 57 58 59 60
{-cleanLeftoverProcesses :: Shell ()-}
{-cleanLeftoverProcesses = do-}
  {-printInfo "Cleaning leftover processes.\n"-}
  {-daemon <- myWhich "daemon"-}
  {-verboseShell (format ("pkill " % fp) daemon) empty-}
  {-cmd <- myWhich "cmd"-}
  {-void $ verboseShell (format ("pkill " % fp) cmd) empty-}
  {-daemon_wrapped <- myWhichMaybe ".daemon-wrapped"-}
  {-E.whenJust daemon_wrapped-}
             {-(\x -> void $ verboseShell "pkill .daemon-wrapped" empty)-}
  {-cmd_wrapped <- myWhichMaybe ".cmd-wrapped"-}
  {-void $ E.whenJust cmd_wrapped-}
                    {-(\x -> void $ verboseShell "pkill .cmd-wrapped" empty)-}
61

62 63
cleanLeftovers :: StackArgs -> Shell ()
cleanLeftovers StackArgs {..} = do
64
  {-cleanLeftoverProcesses-}
65
  printInfo "Cleaning leftover files.\n"
66
  CM.mapM_
67
    cleanLog
68 69
    [ workingDirectory </> daemon_out
    , workingDirectory </> daemon_err
70 71 72 73
    , workingDirectory </> cmd_run_out
    , workingDirectory </> cmd_run_err
    , workingDirectory </> cmd_listen_out
    , workingDirectory </> cmd_listen_err
74 75 76
    , workingDirectory </> nrm_log
    , workingDirectory </> ".argo_nodeos_config_exit_message"
    , workingDirectory </> "argo_nodeos_config"
77
    ]
78
  printInfo "Cleaning leftover sockets.\n"
79
  CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
80

81 82 83 84 85 86 87 88 89 90 91
checkFsAttributes :: StackArgs -> Shell ()
checkFsAttributes StackArgs {..} = do
  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

92
prepareDaemon :: StackArgs -> Shell Instrumentation
93
prepareDaemon sa@StackArgs {..} = do
94
  mktree workingDirectory
95
  checkFsAttributes sa
96
  cd workingDirectory
97
  myWhich "daemon"
98 99
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
100 101 102
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
103
  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
104 105 106
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
107
  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
108 109
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
110
  cleanContainers confPath' 1 4
111
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
112
  return $ Instrumentation
113 114 115 116 117 118
    { process    = P.proc "daemon" ["--nrm_log", encodeString nrm_log]
    , stdOutFile = daemon_out
    , stdErrFile = daemon_err
    , messageOut = messageDaemonOut
    , messageErr = messageDaemonErr
    }
119 120 121 122 123 124
 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"
125
        view $ input ".argo_nodeos_config_exit_message"
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
      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."
168

169 170
prepareCmdRun :: StackArgs -> Instrumentation
prepareCmdRun StackArgs {..} = Instrumentation
171 172 173 174 175 176 177 178
  { process    = P.proc "cmd"
    $  [ "run"
       , "-u"
       , T.unpack containerName
       , encodeString $ manifestDir </> manifestName
       , T.unpack app
       ]
    ++ fmap T.unpack args
179 180 181 182 183 184 185 186 187 188 189 190 191
  , stdOutFile = cmd_run_out
  , stdErrFile = cmd_run_err
  , messageOut = messageCmdRunOut
  , messageErr = messageCmdRunErr
  }

prepareCmdListen :: StackArgs -> Instrumentation
prepareCmdListen StackArgs {..} = Instrumentation
  { process    = P.proc "cmd" ["listen", "-u", T.unpack containerName]
  , stdOutFile = cmd_listen_out
  , stdErrFile = cmd_listen_err
  , messageOut = messageCmdListenOut
  , messageErr = messageCmdListenErr
192
  }
193

194
data StackOutput = FoundMessage | DaemonDied | CmdDied
195

196 197
runSimpleStack :: StackArgs -> Shell StackOutput
runSimpleStack a@StackArgs {..} = do
198
  cleanLeftovers a
199 200
  iDaemon <- prepareDaemon a
  let iRun = prepareCmdRun a
Valentin Reis's avatar
Valentin Reis committed
201
  printInfo "Running the daemon.."
202
  liftIO $ withAsync (runI iDaemon) $ \daemon -> do
203
    kbInstallHandler $ cancel daemon
Valentin Reis's avatar
Valentin Reis committed
204
    sh $ printInfo "Daemon running.\n"
205 206 207
    sh $ printInfo "Running 'cmd run'.."
    withAsync (runI iRun) $ \cmd -> do
      sh $ printInfo "'cmd run' running.\n"
208 209
      kbInstallHandler $ cancel daemon >> cancel cmd
      waitEitherCancel daemon cmd >>= \case
210 211 212 213
        Left  (Left  PatternMatched) -> return FoundMessage
        Left  (Right _             ) -> return DaemonDied
        Right (Left  PatternMatched) -> return FoundMessage
        Right (Right _             ) -> return CmdDied
214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252


data ListenAsyncConclusion a = Daemon a | Listen a | Run a
data ListenStackOutput = LSFoundMessage | LSMessageNotFound | LSDaemonDied ExitCode | LSRunDied ExitCode | LSListenDied ExitCode

runListenStack :: StackArgs -> Shell ListenStackOutput
runListenStack a@StackArgs {..} = do
  cleanLeftovers a
  iDaemon <- prepareDaemon a
  let iRun    = prepareCmdRun a
  let iListen = prepareCmdListen a
  printInfo "Running the daemon.."
  liftIO $ withAsync (runI iDaemon) $ \daemon -> do
    kbInstallHandler $ cancel daemon
    sh $ printInfo "Daemon running.\n"
    sh $ printInfo "Running 'cmd run'.."
    withAsync (runI iRun) $ \run -> do
      sh $ printInfo "'cmd run' running.\n"
      kbInstallHandler $ cancel daemon >> cancel run
      sh $ printInfo "Running 'cmd listen'.."
      withAsync (runI iListen) $ \listen -> do
        sh $ printInfo "'cmd listen' running.\n"
        kbInstallHandler $ cancel daemon >> cancel run >> cancel listen
        waitStackCancel daemon run listen >>= \case
          Daemon (Left  PatternMatched) -> return LSFoundMessage
          Daemon (Right (e, _, _)     ) -> return $ LSDaemonDied e
          Run    (Left  PatternMatched) -> return LSFoundMessage
          Run    (Right (e, _, _)     ) -> return $ LSRunDied e
          Listen (Left  PatternMatched) -> return LSFoundMessage
          Listen (Right (e, _, _)     ) -> return $ LSListenDied e
 where
  waitStackCancel daemon run listen =
    waitStack daemon run listen
      `finally` (cancel daemon >> cancel run >> cancel listen)
  waitStack daemon run listen =
    atomically
      $        (Daemon <$> waitSTM daemon)
      `orElse` (Run <$> waitSTM run)
      `orElse` (Listen <$> waitSTM listen)