Args.hs 4.88 KB
Newer Older
Valentin Reis's avatar
Valentin Reis committed
1
{-# LANGUAGE OverloadedStrings, ApplicativeDo, GeneralizedNewtypeDeriving, RecordWildCards #-}
2 3 4 5

module Argo.Args where

import           Options.Applicative           as OA
Valentin Reis's avatar
Valentin Reis committed
6 7
import           Options.Applicative.Types
import           Options.Applicative.Builder    ( option )
8 9 10 11
import           Data.Default
import           Data.Text                     as T
                                         hiding ( empty )

Valentin Reis's avatar
Valentin Reis committed
12
import           Turtle                  hiding ( option )
13 14 15 16
import           Prelude                 hiding ( FilePath )


data StackArgs = StackArgs
17 18
  { verbosity              :: Verbosity
  , app                    :: AppName
19
  , args                   :: [AppArg]
Valentin Reis's avatar
Valentin Reis committed
20 21 22 23 24 25 26 27
  , containerName          :: ContainerName
  , workingDirectory       :: WorkingDirectory
  , manifestDir            :: ManifestDir
  , manifestName           :: ManifestName
  , daemon                 :: ProcessBehavior
  , cmdrun                 :: ProcessBehavior
  , cmdlisten              :: ProcessBehavior
  , cmdlistenprogress      :: ProcessBehavior
28
  , cmdlistenperformance   :: ProcessBehavior
Valentin Reis's avatar
Valentin Reis committed
29
  , cmdlistenpower         :: ProcessBehavior
30 31
  }

32
{-data OutputFiles = OutputFiles FilePath FilePath-}
33
data Verbosity = Normal | Verbose deriving (Show,Read,Eq)
34
newtype AppArg = AppArg Text deriving (IsString, Show, Read)
Valentin Reis's avatar
Valentin Reis committed
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
newtype WorkingDirectory = WorkingDirectory FilePath deriving (IsString, Show)
newtype AppName = AppName Text deriving (IsString, Show, Read)
newtype ContainerName = ContainerName Text deriving (IsString, Show, Read)
newtype ManifestDir = ManifestDir FilePath deriving (IsString, Show)
newtype ManifestName = ManifestName FilePath deriving (IsString, Show)

newtype StdOutLog = StdOutLog Text deriving (Show, Read)
newtype StdErrLog = StdErrLog Text deriving (Show, Read)
newtype TestText = TestText Text deriving (Show, Read)

data ProcessBehavior =
     SucceedTestOnMessage TestText StdOutLog StdErrLog
   | JustRun StdOutLog StdErrLog
   | DontRun deriving (Show,Read)

behavior :: ReadM ProcessBehavior
behavior = read <$> readerAsk
behaviorOption :: Mod OptionFields ProcessBehavior -> Parser ProcessBehavior
behaviorOption = option behavior

55 56
instance Default StackArgs where
  def = StackArgs
Valentin Reis's avatar
Valentin Reis committed
57
    { verbosity = Normal
58
    , app = AppName "ls"
59
    , args = []
Valentin Reis's avatar
Valentin Reis committed
60 61 62 63 64 65 66 67
    , containerName = ContainerName "testContainer"
    , workingDirectory = WorkingDirectory "_output"
    , manifestDir = ManifestDir "manifests"
    , manifestName = ManifestName "basic.json"
    , daemon = DontRun
    , cmdrun = DontRun
    , cmdlisten = DontRun
    , cmdlistenprogress = DontRun
68
    , cmdlistenperformance = DontRun
Valentin Reis's avatar
Valentin Reis committed
69
    , cmdlistenpower = DontRun
70 71 72
    }

parseExtendStackArgs :: StackArgs -> Parser StackArgs
73
parseExtendStackArgs sa = do
74 75 76 77
  verbosity <- flag
    Normal
    Verbose
    (long "verbose" <> short 'v' <> help "Enable verbose mode")
78
  app <- strOption
79
    (  long "app"
80 81 82
    <> metavar "APP"
    <> help "Target application executable name. PATH is inherited."
    <> showDefault
83
    <> value (app sa)
84
    )
85 86 87 88
  args <- many ( argument auto
    (  metavar "ARGS"
    <> help "Application arguments."
    ))
89 90 91 92 93
  containerName <- strOption
    (  long "container_name"
    <> metavar "ARGO_CONTAINER_UUID"
    <> help "Container name"
    <> showDefault
94
    <> value (containerName sa)
95 96
    )
  workingDirectory <- strOption
97 98
    (  long "output_dir"
    <> metavar "DIR"
99 100
    <> help "Working directory."
    <> showDefault
101
    <> value (workingDirectory sa)
102 103 104
    )
  manifestDir <- strOption
    (  long "manifest_directory"
105
    <> metavar "DIR"
106 107
    <> help "Manifest lookup directory"
    <> showDefault
108
    <> value (manifestDir sa)
109 110 111
    )
  manifestName <- strOption
    (  long "manifest_name"
112 113
    <> metavar "FILENAME"
    <> help "Manifest file basename (relative to --manifest_directory)"
114
    <> showDefault
115
    <> value (manifestName sa)
116
    )
Valentin Reis's avatar
Valentin Reis committed
117 118 119 120
  daemon <- behaviorOption
    (  long "daemon"
    <> metavar "BEHAVIOR"
    <> help "`daemon` behavior"
121
    <> showDefault
122
    <> value (daemon sa)
123
    )
Valentin Reis's avatar
Valentin Reis committed
124 125 126 127
  cmdrun <- behaviorOption
    (  long "cmd_run"
    <> metavar "BEHAVIOR"
    <> help "`cmd run` behavior"
128
    <> showDefault
129
    <> value (cmdrun sa)
130
    )
Valentin Reis's avatar
Valentin Reis committed
131 132 133 134
  cmdlisten <- behaviorOption
    (  long "cmd_listen"
    <> metavar "BEHAVIOR"
    <> help "`cmd listen` behavior"
135
    <> showDefault
136 137 138 139 140 141 142 143
    <> value (cmdlisten sa)
    )
  cmdlistenperformance <- behaviorOption
    (  long "cmd_listen_performance"
    <> metavar "BEHAVIOR"
    <> help "`cmd listen --filter performance` behavior"
    <> showDefault
    <> value (cmdlistenperformance sa)
144
    )
Valentin Reis's avatar
Valentin Reis committed
145 146 147 148
  cmdlistenprogress <- behaviorOption
    (  long "cmd_listen_progress"
    <> metavar "BEHAVIOR"
    <> help "`cmd listen --filter progress` behavior"
149
    <> showDefault
150
    <> value (cmdlistenprogress sa)
151
    )
Valentin Reis's avatar
Valentin Reis committed
152 153 154 155
  cmdlistenpower <- behaviorOption
    (  long "cmd_listen_power"
    <> metavar "BEHAVIOR"
    <> help "`cmd listen --filter power` behavior"
156
    <> showDefault
157
    <> value (cmdlistenpower sa)
158 159
    )
  pure StackArgs {..}