Stack.hs 7.63 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
{-# LANGUAGE ScopedTypeVariables, LambdaCase , RecordWildCards , OverloadedStrings ,
  DataKinds , FlexibleInstances , TypeOperators #-}

module Argo.Stack where

import           Data.Default
import           Turtle
import           Prelude                 hiding ( FilePath )

import           System.IO                      ( withFile )
import           Debug.Trace
import           Filesystem.Path                ( (</>) )
import           Control.Concurrent.Async
import           System.Console.ANSI 
import           System.Console.ANSI.Types      ( Color )
import           Data.Text                     as Text
                                         hiding ( empty )
import           Data.Text.IO                  as Text
import           Argo.Utils
import System.Process as P hiding (shell)

data StackArgs = StackArgs
  { dargs                :: [Text]      --"Daemon arguments. Properly quote this."
  , app                  :: Text        --"Target application call, sh+path valid"
  , workingDirectory     :: FilePath    --"Working directory."
  , manifest             :: FilePath    --"Input file, manifest."
  , cmd_out              :: FilePath    --"Output file, application stdout"
  , cmd_err              :: FilePath    --"Output file, application stderr"
  , daemon_out           :: FilePath    --"Output file, daemon stdout"
  , daemon_err           :: FilePath    --"Output file, daemon stderr"
  , nrm_log              :: FilePath    --"Output file, daemon log"
  , time_file            :: FilePath  } --"Output file, application runtime"

instance Default StackArgs where
  def = StackArgs
    { dargs = []
    , app = "echo \"HelloWorld\""
    , workingDirectory = "./."
    , manifest = "basic.json"
    , cmd_out = "cmd_out.log"
    , cmd_err = "cmd_err.log"
    , daemon_out = "daemon_out.log"
    , daemon_err = "daemon_err.log"
    , nrm_log = "nrm.log"
    , time_file = "time.log"
    }

-- | override the output directory of the stack.
outputDir :: FilePath -> StackArgs -> StackArgs
outputDir dir sa = sa { workingDirectory = dir }

cleanLeftovers
  :: FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> FilePath
  -> Shell ()
cleanLeftovers wd daemon_out daemon_err cmd_out cmd_err time_file nrm_log = do
  printInfo "Cleaning leftovers..\n"
  mapM_
    cleanLog
    [ wd </> daemon_out
    , wd </> daemon_err
    , wd </> cmd_out
    , wd </> cmd_err
    , wd </> time_file
    , wd </> nrm_log
    , wd </> ".argo_nodeos_config_exit_message"
    ]
  mapM_ cleanSocket ["/tmp/nrm-downstream-in", "/tmp/nrm-upstream-in"]

prepareDaemonShell
  :: FilePath -> [Text] -> FilePath -> FilePath -> FilePath -> Shell (IO ())
prepareDaemonShell wd dargs daemon_out daemon_err nrm_log = do
  mktree wd
  cd wd
  myWhich "daemon"
81
82
  confPath <- myWhich "argo_nodeos_config"
  let confPath' = "./argo_nodeos_config"
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
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
144
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
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
  cp confPath confPath'
  printInfo $ format ("Copied the configurator to " % fp % "\n") confPath'
  printInfo $ format "Trying to sudo chown and chmod argo_nodeos_config\n"
  shell (format ("sudo chown root:root " % fp) confPath') empty >>= \case
    ExitSuccess -> printInfo "Chowned argo_nodeos_config to root:root.\n"
    ExitFailure n ->
      die ("Failed to set argo_nodeos_config permissions " <> repr n)
  shell (format ("sudo chmod u+sw " % fp) confPath') empty >>= \case
    ExitSuccess   -> printInfo "Set the suid bit.\n"
    ExitFailure n -> die ("Setting suid bit failed with exit code " <> repr n)

  --Cleaning the config, running the daemon
  shell (format (fp % " --clean_config=kill_content:true") confPath') empty
    >>= \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)
  printInfo $ format
    ( "Running the daemon, main log at "
    % fp
    % ", stdout at "
    % fp
    % ", stderr at "
    % fp
    % "\n"
    )
    nrm_log
    daemon_out
    daemon_err
  export "ARGO_NODEOS_CONFIG" (format fp confPath')
  return $ twoWayPrint daemon_out daemon_err $ inprocWithErr
    "daemon"
    (dargs ++ ["--nrm_log", Text.pack $ encodeString nrm_log])
    empty

-- | See at the bottom of this file for discussion of this function. (1)
cmdShell :: FilePath -> Text -> FilePath -> FilePath -> Shell ()
cmdShell manifest app cmd_out cmd_err = do
  shell
      (format ("cmd run -u toto " % fp % "  " % s % " > " % fp % " 2>" % fp)
              manifest
              app
              cmd_out
              cmd_err
      )
      empty
    >>= \case
          ExitSuccess   -> printInfo "cmd has exited successfuly.\n"
          ExitFailure n -> die
            (  "cmd failed with exit code "
            <> repr n
            <> " . The application logs are at "
            <> repr cmd_out
            <> " "
            <> repr cmd_err
            )

twoWayPrint :: FilePath -> FilePath -> Shell (Either Line Line) -> IO ()
twoWayPrint outPath errPath s = sh $ do
  handleOut <- using (writeonly outPath)
  handleErr <- using (writeonly errPath)
  s >>= \case
    Left  out -> liftIO $ Text.hPutStrLn handleOut (lineToText out)
    Right err -> liftIO $ Text.hPutStrLn handleErr (lineToText err)

runSimpleStack :: StackArgs -> IO ()
runSimpleStack a@StackArgs {..} = sh $ do
  cleanLeftovers workingDirectory
                 daemon_out
                 daemon_err
                 cmd_out
                 cmd_err
                 time_file
                 nrm_log
  daemonShell <- prepareDaemonShell workingDirectory
                                    dargs
                                    daemon_out
                                    daemon_err
                                    nrm_log
  liftIO $ withAsync daemonShell $ \daemon -> do
    kbInstallHandler $ cancel daemon
    withAsync (time $ sh $ cmdShell manifest app cmd_out cmd_err) $ \cmd -> do
      kbInstallHandler $ cancel daemon >> cancel cmd
      waitEitherCancel daemon cmd >>= \case
        Left  _      -> die "Daemon died."
        Right (_, t) -> writeTextFile time_file (repr t)

-- | (1)
--
-- | This version fucks up the environment variables. issue at
-- https://github.com/Gabriel439/Haskell-Turtle-Library/issues/338
{-cmdShell :: FilePath -> Text -> FilePath -> FilePath -> Shell ()-}
{-cmdShell manifest app cmd_out cmd_err = do-}
  {-manifestArg <- case toText manifest of-}
    {-Left m -> printWarning (format ("Manifest path malformed: " % fp) manifest)-}
      {->> return m-}
    {-Right m -> return m-}
  {-printInfo $ format-}
    {-("Running cmd. Stdout at " % fp % ", stderr at " % fp % "\n")-}
    {-cmd_out-}
    {-cmd_err-}
  {-liftIO $ twoWayPrint cmd_out cmd_err $ inprocWithErr-}
    {-"cmd"-}
    {-["run", "-u", "toto", manifestArg, app]-}
    {-empty-}

-- | Even this one fucks up, streamWithErr really cleans this `env` attribute.

  {-manifestArg <- case toText manifest of-}
    {-Left m -> printWarning (format ("Manifest path malformed: " % fp) manifest)-}
      {->> return m-}
    {-Right m -> return m-}
  {-printInfo $ format-}
    {-("Running cmd. Stdout at " % fp % ", stderr at " % fp % "\n")-}
    {-cmd_out-}
    {-cmd_err-}
  {-theEnv' <- liftIO $ Turtle.env-}
  {-let theEnv = Prelude.map (\(x,y)-> (Text.unpack x,Text.unpack y)) theEnv'-}
  {-void $ liftIO $  twoWayPrint cmd_out cmd_err $ streamWithErr ((P.proc (unpack "cmd") (Prelude.map unpack ["run", "-u", "toto", manifestArg, app])) {P.env=Just theEnv}) empty-}