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