GitLab maintenance scheduled for Tomorrow, 2020-03-31, from 17:00 to 18:00 CT - Services will be unavailable during this time.

argotk.hs 4.03 KB
Newer Older
1 2 3
#! /usr/bin/env runhaskell

{-# LANGUAGE
4 5 6
  OverloadedStrings,
  LambdaCase,
  RecordWildCards #-}
7 8 9 10 11 12 13 14 15 16 17 18 19

import           Argo.Stack
import           Argo.Utils
import           Turtle
import           Prelude                 hiding ( FilePath )
import           Data.Default
import           Control.Concurrent.Async
import           System.Environment
import           System.Console.ANSI
import           System.Console.ANSI.Types      ( Color )
import           Options.Applicative
import           System.Posix.Signals
import           Control.Monad
20 21
import           Data.Either

22 23 24 25 26 27
messageOption = strOption
  (  long "message"
  <> metavar "MESSAGE"
  <> help "String to look for in the NRM daemon standard output."
  <> value "progress"
  )
28 29 30 31 32 33 34 35

opts :: StackArgs -> Parser (IO ())
opts sa = hsubparser
  (  command "clean"
             (info (pure $ runClean sa) (progDesc "Clean sockets, logfiles."))
  <> command
       "daemon"
       (info
36
         (runDaemon <$> parseExtendStackArgs sa)
37 38 39 40 41 42
         (progDesc
           "Set up and launch the daemon in synchronous mode, \
           \with properly cleaned sockets, logfiles."
         )
       )
  <> command
43
       "stack"
44 45 46 47 48
       (info (runSimpleStack <$> parseExtendStackArgs sa)
             (progDesc "Setup stack and run a command in a container.")
       )
  <> command
       "grep"
49
       (info
50 51 52 53 54 55 56
         (runWaitForMessage <$> messageOption <*> parseExtendStackArgs
           (sa { app = "echo foobar" })
         )
         (progDesc
           "Setup stack and look for a message in the daemon's \
           \standard output."
         )
57 58 59 60
       )
  <> command
       "helloworld"
       (info
61 62 63
         (runCheckCmdOutput "helloworld" <$> parseExtendStackArgs
           (sa { app = format ("echo " % s) "helloworld" })
         )
64
         (progDesc
65
           "Test 1: Setup stack and check that a hello world app sends \
66 67 68
           \message back to cmd."
         )
       )
69 70 71
  <> command
       "perfwrapper"
       (info
72
         (runWaitForMessage "progress" <$> parseExtendStackArgs
73 74 75 76 77
           (sa { manifestName = "perfwrap.json"
               , app          = format ("sleep " % s) "5"
               }
           )
         )
78
         (progDesc
79 80
           "Test 2: Setup stack and check that argo-perf-wrapper sends \
           \ at least one progress message up."
81 82
         )
       )
83 84 85 86
  <> help
       "Type of test to run. There are extensive options under each action,\
       \ but be careful, these do not all have the same defaults. The default\
       \ values are printed when you call --help on these actions."
87 88 89 90 91
  )

main :: IO ()
main = do
  manifests <- getEnv "MANIFESTS"
92 93
  let a = def { manifestDir = decodeString manifests }
  join $ execParser (info (opts a <**> helper) idm)
94

95 96
runCheckCmdOutput :: Text -> StackArgs -> IO ()
runCheckCmdOutput message a@StackArgs {..} = do
97
  sh cleanLeftoverProcesses
98 99 100
  runSimpleStack a
  readTextFile cmd_err >>= \x -> case match (has (text message)) x of
    [] ->
101
      sh $ dieRed $ "Cmd did not recieve the '" <> message <> "' message.\n"
102 103
    _ ->
      sh
104 105
        $ printSuccess
            "The hello world app executed properly in a \
106 107 108 109
            \ container and its message was received by `cmd`.\n"

runWaitForMessage :: Text -> StackArgs -> IO ()
runWaitForMessage message a@StackArgs {..} = do
110
  sh $ printError "WARNING: TODO: DEBUG. THIS TEST CURRENTLY FAILS ONCE PER TWO RUNS AND REPORTS BAD EXIT CODES.\n"
111
  runSimpleStackWithCriterion criteria a
112
  sh $ dieRed ("Did not find string '" <> message <> "' in daemon stdout.\n")
113 114 115
 where
  criteria :: (Shell (Either Line Line) -> Shell (Either Line Line))
  criteria s = s >>= \case
116
    Left out -> case match (has (text message)) (lineToText out) of
117 118
      [] -> return $ Left out
      _  -> do
119 120
        printSuccess
          $  "Found line containing '"
121
          <> message
122 123
          <> "' in daemon stdout.\n"
        cleanLeftoverProcesses
124 125 126
        exit ExitSuccess
    Right err -> return $ Right err

127
runClean :: StackArgs -> IO ()
128
runClean = sh . cleanLeftovers
129

130
runDaemon :: StackArgs -> IO ()
131
runDaemon a = sh $ prepareDaemonShell a >>= liftIO