Stack.hs 7.56 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 21
import           Prelude                 hiding ( FilePath )

import           System.IO                      ( withFile )
import           Debug.Trace
import           Filesystem.Path                ( (</>) )
import           Control.Concurrent.Async
22
import           System.Console.ANSI
23
import           System.Console.ANSI.Types      ( Color )
24
import           Data.Text                     as T
25 26 27
                                         hiding ( empty )
import           Data.Text.IO                  as Text
import           Argo.Utils
28 29
import           System.Process                as P
                                         hiding ( shell )
30
import           Options.Applicative           as OA
31
import           Control.Monad.Extra           as E
32 33 34 35 36 37 38 39
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
40
import           Control.Foldl                 as Fold
41

42

43 44 45 46 47 48 49 50
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"
51 52
  E.whenJust daemon_wrapped
             (\x -> void $ verboseShell "pkill .daemon-wrapped" empty)
53
  cmd_wrapped <- myWhichMaybe ".cmd-wrapped"
54 55
  void $ E.whenJust cmd_wrapped
                    (\x -> void $ verboseShell "pkill .cmd-wrapped" empty)
56

57 58
cleanLeftovers :: StackArgs -> Shell ()
cleanLeftovers StackArgs {..} = do
59 60
  cleanLeftoverProcesses
  printInfo "Cleaning leftover files.\n"
61
  CM.mapM_
62
    cleanLog
63 64 65 66 67 68 69
    [ workingDirectory </> daemon_out
    , workingDirectory </> daemon_err
    , workingDirectory </> cmd_out
    , workingDirectory </> cmd_err
    , workingDirectory </> nrm_log
    , workingDirectory </> ".argo_nodeos_config_exit_message"
    , workingDirectory </> "argo_nodeos_config"
70
    ]
71
  printInfo "Cleaning leftover sockets.\n"
72
  CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
73

74 75 76 77 78 79 80 81 82 83 84
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

85 86
prepareDaemon
  :: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ())))
87
prepareDaemon sa@StackArgs {..} = do
88
  mktree workingDirectory
89
  checkFsAttributes sa
90
  cd workingDirectory
91
  myWhich "daemon"
92 93
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
94 95 96
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
97
  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
98 99 100
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
101
  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
102 103
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
104
  cleanContainers confPath' 1 4
105
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
106 107 108 109 110 111 112
  makeInstrumentedProcess $ Instrumentation
    { process    = P.proc "daemon" ["--nrm_log", encodeString nrm_log]
    , stdOutFile = daemon_out
    , stdErrFile = daemon_err
    , messageOut = messageDaemonOut
    , messageErr = messageDaemonErr
    }
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 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
 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"
        view $ input "./argo_nodeos_config_exit_message"
      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."
162

163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
prepareCmdRun
  :: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ())))
prepareCmdRun StackArgs {..} = makeInstrumentedProcess $ Instrumentation
  { process    = P.proc "cmd"
    $  [ "run"
       , "-u"
       , T.unpack containerName
       , encodeString $ manifestDir </> manifestName
       , T.unpack app
       ]
    ++ fmap T.unpack args
  , stdOutFile = cmd_out
  , stdErrFile = cmd_err
  , messageOut = messageCmdOut
  , messageErr = messageCmdErr
  }
179

180 181 182
data StackOutput = FoundMessage | DaemonDied | CmdDied
runSimpleStack :: StackArgs -> Shell StackOutput
runSimpleStack a@StackArgs {..} = do
183
  cleanLeftovers a
184 185
  instrumentedDaemon <- prepareDaemon a
  instrumentedCmd    <- prepareCmdRun a
Valentin Reis's avatar
Valentin Reis committed
186
  printInfo "Running the daemon.."
187
  liftIO $ withAsync instrumentedDaemon $ \daemon -> do
188
    kbInstallHandler $ cancel daemon
Valentin Reis's avatar
Valentin Reis committed
189 190
    sh $ printInfo "Daemon running.\n"
    sh $ printInfo "Running cmd.."
191
    withAsync instrumentedCmd $ \cmd -> do
Valentin Reis's avatar
Valentin Reis committed
192
      sh $ printInfo "cmd running.\n"
193 194
      kbInstallHandler $ cancel daemon >> cancel cmd
      waitEitherCancel daemon cmd >>= \case
195 196 197 198
        Left  (Left  PatternMatched) -> return FoundMessage
        Left  (Right _             ) -> return DaemonDied
        Right (Left  PatternMatched) -> return FoundMessage
        Right (Right _             ) -> return CmdDied