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

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

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

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

40

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

55 56
cleanLeftovers :: StackArgs -> Shell ()
cleanLeftovers StackArgs {..} = do
57 58
  cleanLeftoverProcesses
  printInfo "Cleaning leftover files.\n"
59
  CM.mapM_
60
    cleanLog
61 62 63 64 65 66 67
    [ 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"
68
    ]
69
  printInfo "Cleaning leftover sockets.\n"
70
  CM.mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]
71

72 73 74
prepareDaemon
  :: StackArgs -> Shell (IO (Either PatternMatched (ExitCode, (), ())))
prepareDaemon StackArgs {..} = do
75 76
  mktree workingDirectory
  cd workingDirectory
77
  myWhich "daemon"
78 79
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
80 81 82
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
83
  verboseShell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
84 85 86
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
87
  verboseShell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
88 89
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)
90 91
  verboseShell (format (fp % " --clean_config=kill_content:true") confPath')
               empty
92 93 94 95 96 97 98 99 100 101 102
    >>= \case
          ExitSuccess   -> printInfo "Cleaned the argo config.\n"
          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 ("Clean config failed with exit code " <> repr n)
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
103 104 105 106 107 108 109
  makeInstrumentedProcess $ Instrumentation
    { process    = P.proc "daemon" ["--nrm_log", encodeString nrm_log]
    , stdOutFile = daemon_out
    , stdErrFile = daemon_err
    , messageOut = messageDaemonOut
    , messageErr = messageDaemonErr
    }
110

111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
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
  }
127

128 129 130
data StackOutput = FoundMessage | DaemonDied | CmdDied
runSimpleStack :: StackArgs -> Shell StackOutput
runSimpleStack a@StackArgs {..} = do
131
  cleanLeftovers a
132 133
  instrumentedDaemon <- prepareDaemon a
  instrumentedCmd    <- prepareCmdRun a
Valentin Reis's avatar
Valentin Reis committed
134
  printInfo "Running the daemon.."
135
  liftIO $ withAsync instrumentedDaemon $ \daemon -> do
136
    kbInstallHandler $ cancel daemon
Valentin Reis's avatar
Valentin Reis committed
137 138
    sh $ printInfo "Daemon running.\n"
    sh $ printInfo "Running cmd.."
139
    withAsync instrumentedCmd $ \cmd -> do
Valentin Reis's avatar
Valentin Reis committed
140
      sh $ printInfo "cmd running.\n"
141 142
      kbInstallHandler $ cancel daemon >> cancel cmd
      waitEitherCancel daemon cmd >>= \case
143 144 145 146
        Left  (Left  PatternMatched) -> return FoundMessage
        Left  (Right _             ) -> return DaemonDied
        Right (Left  PatternMatched) -> return FoundMessage
        Right (Right _             ) -> return CmdDied