95f660c · typeable/octopod

git.iko.soy/typeable/octopod

refactoring

commit95f660cff38c308bfac73a084d3a40a2c8b2453c authorAndrei Orlov <aaorlov1@gmail.com> dateFri 5 Jun 2020, 16:28 (6 years ago) parentf326921

7 files changed+246−251

compare with master

unifiedsplit

src/DMC.hs+62−59 src/DMC/Args.hs+43−54 src/DMS.hs+79−79 src/DMS/Args.hs+14−16 src/DMS/Kubernetes.hs+4−3 src/TLS.hs+36−35 src/Types.hs+8−5

src/DMC.hs+62−59

@@ -1,53 +1,54 @@

11module DMC (runDMC) where

3−import Chronos

4−import Control.Lens hiding (List)

5−import Control.Monad

6−import Control.Monad.IO.Class

7−import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)

3+import Chronos

4+import Control.Lens hiding (List)

5+import Control.Monad

6+import Control.Monad.IO.Class

7+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)

88import qualified Data.ByteString.Char8 as BSC

9−import Data.Coerce

10−import Data.Foldable

11−import Data.Generics.Product

12−import Data.Maybe (fromMaybe)

13−import Data.Proxy

14−import Data.Text as T

15−import Data.Text.IO as T

16−import Data.Text.Lens

17−import Network.URI

18−import Prelude as P

19−import Servant.API

20−import Servant.Client

21− ( ClientError, BaseUrl(..), ClientEnv, ClientM, Scheme(..)

9+import Data.Coerce

10+import Data.Foldable

11+import Data.Generics.Product

12+import Data.Maybe (fromMaybe)

13+import Data.Proxy

14+import Data.Text as T

15+import Data.Text.IO as T

16+import Data.Text.Lens

17+import Network.URI

18+import Prelude as P

19+import Servant.API

20+import Servant.Client

21+ (ClientError, BaseUrl(..), ClientEnv, ClientM, Scheme(..)

2222 , runClientM, client, mkClientEnv)

23−import System.Environment (lookupEnv)

24−import System.IO

25−import System.IO.Temp

26−import System.Process.Typed

23+import System.Environment (lookupEnv)

24+import System.IO

25+import System.IO.Temp

26+import System.Process.Typed

2727

28−import API

29−import DMC.Args

30−import TLS (makeClientManager)

31−import Types

28+import API

29+import DMC.Args

30+import TLS (makeClientManager)

31+import Types

3232

3333runDMC :: IO ()

3434runDMC = do

3535 args <- parseArgs

36− let cert = maybe "cert.pem" (BSC.unpack . unTLSCertPath) $ dmcTLSCertPath args

37− key = maybe "key.pem" (BSC.unpack . unTLSKeyPath) $ dmcTLSKeyPath args

36+ let

37+ cert = maybe "cert.pem" (BSC.unpack . unTLSCertPath) $ dmcTLSCertPath args

38+ key = maybe "key.pem" (BSC.unpack . unTLSKeyPath) $ dmcTLSKeyPath args

3839 manager <- makeClientManager dmsHostName cert key

3940 env <- getBaseUrl

4041 let clientEnv = mkClientEnv manager env

4142 flip runReaderT clientEnv $

4243 case args of

43− CreateC n t e _ _ -> do

44− envPairs <- liftIO $ parseEnvs e

45− handleCreate $ Deployment (coerce n) (coerce t) envPairs

46− ListC _ _ -> handleList

47− EditC tName _ _ -> handleEdit $ DeploymentName tName

48− DestroyC tName _ _ -> handleDestroy $ DeploymentName tName

49− UpdateC tName tTag _ _ -> handleUpdate (DeploymentName tName) (DeploymentTag tTag)

50− InfoC tName _ _ -> handleInfo $ DeploymentName tName

44+ CreateC tName tTag tEnvs _ _ -> do

45+ envPairs <- liftIO $ parseEnvs tEnvs

46+ handleCreate $ Deployment (coerce tName) (coerce tTag) envPairs

47+ ListC _ _ -> handleList

48+ EditC tName _ _ -> handleEdit . DeploymentName $ tName

49+ DestroyC tName _ _ -> handleDestroy . DeploymentName $ tName

50+ UpdateC tName tTag _ _ -> handleUpdate (DeploymentName tName) (DeploymentTag tTag)

51+ InfoC tName _ _ -> handleInfo . DeploymentName $ tName

5152

5253dmsHostName :: String

5354dmsHostName = "dm.stage.thebestagent.pro"

@@ -67,10 +68,10 @@ getBaseUrl = do

6768 uri <- parseURI url

6869 uriData <- uriAuthority uri

6970 let

70− s = if uriScheme uri == "https:" then Https else Http

71− h = uriRegName uriData

72− p = read . P.tail . uriPort $ uriData

73− return $ BaseUrl s h p ""

71+ schema = if uriScheme uri == "https:" then Https else Http

72+ host = uriRegName uriData

73+ port = read . P.tail . uriPort $ uriData

74+ return $ BaseUrl schema host port ""

7475 return $ maybe defaultBaseUrl parseUrl dmsURL

7576

7677handleCreate :: Deployment -> ReaderT ClientEnv IO ()

@@ -84,34 +85,36 @@ handleList :: ReaderT ClientEnv IO ()

8485handleList = do

8586 clientEnv <- ask

8687 liftIO $ do

87− l <- runClientM listH clientEnv

88− handleResponse T.putStr $ T.unlines . coerce . (dn <$>) <$> l

89− where dn (DeploymentFullInfo (Deployment n _ _) _ _ _) = n

88+ resp <- runClientM listH clientEnv

89+ let

90+ getName (DeploymentFullInfo (Deployment dName _ _) _ _ _) = dName

91+ names = T.unlines . coerce . (getName <$>) <$> resp

92+ handleResponse T.putStr names

9093

9194handleEdit :: DeploymentName -> ReaderT ClientEnv IO ()

9295handleEdit dName = do

9396 clientEnv <- ask

9497 liftIO $ do

95− editor <- lookupEnv "EDITOR"

96− case editor of

97− Just ed -> do

98+ editorPath <- lookupEnv "EDITOR"

99+ case editorPath of

100+ Just editor -> do

98101 res <- flip runClientM clientEnv $ getH dName

99102 case res of

100− Right (Deployment _ _ e) -> do

101− envPairs <- editEnvs ed e

103+ Right (Deployment _ _ dEnvs) -> do

104+ envPairs <- editEnvs editor dEnvs

102105 response <- runClientM (editH dName envPairs) clientEnv

103106 handleResponse (const $ pure ()) response

104− Left err ->

107+ Left err ->

105108 P.print $ "request failed, reason: " <> show err

106− Nothing -> error "environment variable $EDITOR not found"

109+ Nothing -> error "environment variable $EDITOR not found"

107110

108111editEnvs :: FilePath -> EnvPairs -> IO EnvPairs

109−editEnvs ed e = withTempFile "" "dmc" $ \p h -> do

110− for_ e $ \(k,v) -> (T.hPutStrLn h $ k <> "=" <> v)

111− hFlush h

112− withProcessWait_ (proc ed [p]) $ \_ -> T.hPutStrLn h "processing update..."

113− l <- T.lines <$> T.readFile p

114− envPairs <- parseEnvs l

112+editEnvs editor currentEnvPairs = withTempFile "" "dmc" $ \filePath handle -> do

113+ for_ currentEnvPairs $ \(k, v) -> (T.hPutStrLn handle $ k <> "=" <> v)

114+ hFlush handle

115+ withProcessWait_ (proc editor [filePath]) $ \_ -> T.hPutStrLn handle "processing update..."

116+ rawEnvs <- T.lines <$> T.readFile filePath

117+ envPairs <- parseEnvs rawEnvs

115118 T.putStrLn "sending update..."

116119 pure envPairs

117120

@@ -134,8 +137,8 @@ handleInfo dName = do

134137 res <- runClientM (infoH dName) clientEnv

135138 case res of

136139 Right (i : _) -> printInfo i

137− Right [] -> print $ "deployment " ++ unpack (coerce dName) ++ " not found"

138− Left err -> print $ "request failed, reason: " ++ show err

140+ Right [] -> print $ "deployment " ++ unpack (coerce dName) ++ " not found"

141+ Left err -> print $ "request failed, reason: " ++ show err

139142

140143listH :: ClientM [DeploymentFullInfo]

141144

@@ -163,7 +166,7 @@ infoH :: DeploymentName -> ClientM [DeploymentInfo]

163166

164167handleResponse :: (a -> IO ()) -> Either ClientError a -> IO ()

165168handleResponse f (Right result) = f result

166−handleResponse _ (Left err) =

169+handleResponse _ (Left err) =

167170 T.putStrLn $ "command failed, reason: " <> T.pack (show err)

168171

169172printInfo :: DeploymentInfo -> IO ()

src/DMC/Args.hs+43−54

@@ -9,31 +9,26 @@ import Types

99-- | CLI options

1010-- FIXME: add options documentation

1111data Args

12− = Create { name :: Text

13− , tag :: Text

14− , envs :: [Text]

15− , tlsCertPath :: Maybe ByteString

16− , tlsKeyPath :: Maybe ByteString

17− }

18− | List { tlsCertPath :: Maybe ByteString

19− , tlsKeyPath :: Maybe ByteString

20− }

21− | Edit { name :: Text

22− , tlsCertPath :: Maybe ByteString

23− , tlsKeyPath :: Maybe ByteString

24− }

25− | Destroy { name :: Text

12+ = Create { name :: Text

13+ , tag :: Text

14+ , envs :: [Text]

15+ , tlsCertPath :: Maybe ByteString

16+ , tlsKeyPath :: Maybe ByteString }

17+ | List { tlsCertPath :: Maybe ByteString

18+ , tlsKeyPath :: Maybe ByteString }

19+ | Edit { name :: Text

20+ , tlsCertPath :: Maybe ByteString

21+ , tlsKeyPath :: Maybe ByteString }

22+ | Destroy { name :: Text

2623 , tlsCertPath :: Maybe ByteString

27− , tlsKeyPath :: Maybe ByteString

28− }

29− | Update { name :: Text

30− , tag :: Text

31− , tlsCertPath :: Maybe ByteString

32− , tlsKeyPath :: Maybe ByteString

33− }

34− | Info { name :: Text, tlsCertPath :: Maybe ByteString

35− , tlsKeyPath :: Maybe ByteString

36− }

24+ , tlsKeyPath :: Maybe ByteString }

25+ | Update { name :: Text

26+ , tag :: Text

27+ , tlsCertPath :: Maybe ByteString

28+ , tlsKeyPath :: Maybe ByteString }

29+ | Info { name :: Text

30+ , tlsCertPath :: Maybe ByteString

31+ , tlsKeyPath :: Maybe ByteString }

3732 deriving stock (Show, Generic)

3833

3934instance ParseRecord Args where

@@ -42,41 +37,35 @@ instance ParseRecord Args where

4237 { shortNameModifier = firstLetter }

4338

4439data DMCArgs

45− = CreateC { deploymentName :: Text

46− , deploymentTag :: Text

47− , deploymentEnvs :: [Text]

48− , dmcTLSCertPath :: Maybe TLSCertPath

49− , dmcTLSKeyPath :: Maybe TLSKeyPath

50− }

51− | ListC { dmcTLSCertPath :: Maybe TLSCertPath

52− , dmcTLSKeyPath :: Maybe TLSKeyPath

53− }

54− | EditC { deploymentName :: Text

55− , dmcTLSCertPath :: Maybe TLSCertPath

56− , dmcTLSKeyPath :: Maybe TLSKeyPath

57− }

40+ = CreateC { deploymentName :: Text

41+ , deploymentTag :: Text

42+ , deploymentEnvs :: [Text]

43+ , dmcTLSCertPath :: Maybe TLSCertPath

44+ , dmcTLSKeyPath :: Maybe TLSKeyPath }

45+ | ListC { dmcTLSCertPath :: Maybe TLSCertPath

46+ , dmcTLSKeyPath :: Maybe TLSKeyPath }

47+ | EditC { deploymentName :: Text

48+ , dmcTLSCertPath :: Maybe TLSCertPath

49+ , dmcTLSKeyPath :: Maybe TLSKeyPath }

5850 | DestroyC { deploymentName :: Text

5951 , dmcTLSCertPath :: Maybe TLSCertPath

60− , dmcTLSKeyPath :: Maybe TLSKeyPath

61− }

62− | UpdateC { deploymentName :: Text

63− , deploymentTag :: Text

64− , dmcTLSCertPath :: Maybe TLSCertPath

65− , dmcTLSKeyPath :: Maybe TLSKeyPath

66− }

67− | InfoC { deploymentName :: Text

68− , dmcTLSCertPath :: Maybe TLSCertPath

69− , dmcTLSKeyPath :: Maybe TLSKeyPath

70− }

52+ , dmcTLSKeyPath :: Maybe TLSKeyPath }

53+ | UpdateC { deploymentName :: Text

54+ , deploymentTag :: Text

55+ , dmcTLSCertPath :: Maybe TLSCertPath

56+ , dmcTLSKeyPath :: Maybe TLSKeyPath }

57+ | InfoC { deploymentName :: Text

58+ , dmcTLSCertPath :: Maybe TLSCertPath

59+ , dmcTLSKeyPath :: Maybe TLSKeyPath }

7160 deriving stock (Show, Generic)

7261

7362parseArgs :: IO DMCArgs

7463parseArgs = do

7564 args <- getRecord "DMC"

7665 pure $ case args of

77− Create n t e c k -> CreateC n t e (coerce <$> c) (coerce <$> k)

78− List c k -> ListC (coerce <$> c) (coerce <$> k)

79− Edit n c k -> EditC n (coerce <$> c) (coerce <$> k)

80− Destroy n c k -> DestroyC n (coerce <$> c) (coerce <$> k)

81− Update n t c k -> UpdateC n t (coerce <$> c) (coerce <$> k)

82− Info n c k -> InfoC n (coerce <$> c) (coerce <$> k)

66+ Create n t e c k -> CreateC n t e (coerce <$> c) (coerce <$> k)

67+ List c k -> ListC (coerce <$> c) (coerce <$> k)

68+ Edit n c k -> EditC n (coerce <$> c) (coerce <$> k)

69+ Destroy n c k -> DestroyC n (coerce <$> c) (coerce <$> k)

70+ Update n t c k -> UpdateC n t (coerce <$> c) (coerce <$> k)

71+ Info n c k -> InfoC n (coerce <$> c) (coerce <$> k)

src/DMS.hs+79−79

@@ -33,20 +33,19 @@ import Types

3333

3434

3535type PgPool = Pool Connection

36−type AppM = ReaderT AppState Handler

36+type AppM = ReaderT AppState Handler

3737

3838data AppState = AppState

39− { pool :: PgPool

40− , logger :: TimedFastLogger

41− , project_name :: ProjectName

42− , base_domain :: Domain

43− , namespace :: Namespace

44− , creation_command :: Command

45− , update_command :: Command

39+ { pool :: PgPool

40+ , logger :: TimedFastLogger

41+ , project_name :: ProjectName

42+ , base_domain :: Domain

43+ , namespace :: Namespace

44+ , creation_command :: Command

45+ , update_command :: Command

4646 , update_envs_command :: Command

47− , deletion_command :: Command

48− , checking_command :: Command

49− }

47+ , deletion_command :: Command

48+ , checking_command :: Command }

5049

5150data DeploymentException

5251 = DeploymentFailed Int

@@ -61,30 +60,32 @@ runDMS = do

6160 (logger', _) <- newTimedFastLogger timeCache (LogStdout defaultBufSize)

6261 logInfo logger' "started"

6362 opts <- parseArgs

64− let a ?! e = a >>= maybe (die e) pure

65− proj_name <- coerce . pack <$> lookupEnv "PROJECT_NAME" ?! "PROJECT_NAME is not set"

66− domain <- coerce . pack <$> lookupEnv "BASE_DOMAIN" ?! "BASE_DOMAIN is not set"

67− ns <- coerce . pack <$> lookupEnv "NAMESPACE" ?! "NAMESPACE is not set"

68− creation_cmd <- coerce . pack <$> lookupEnv "CREATION_COMMAND" ?! "CREATION_COMMAND is not set"

69− update_cmd <- coerce . pack <$> lookupEnv "UPDATE_COMMAND" ?! "UPDATE_COMMAND is not set"

70− update_envs_cmd <- coerce . pack <$> lookupEnv "UPDATE_ENVS_COMMAND" ?! "UPDATE_ENVS_COMMAND is not set"

71− deletion_cmd <- coerce . pack <$> lookupEnv "DELETION_COMMAND" ?! "DELETION_COMMAND is not set"

72− checking_cmd <- coerce . pack <$> lookupEnv "CHECKING_COMMAND" ?! "CHECKING_COMMAND is not set"

63+ let

64+ a ?! e = a >>= maybe (die e) pure

65+ getEnvOrDie eName = lookupEnv eName ?! (eName <> " is not set")

66+ proj_name <- coerce . pack <$> getEnvOrDie "PROJECT_NAME"

67+ domain <- coerce . pack <$> getEnvOrDie "BASE_DOMAIN"

68+ ns <- coerce . pack <$> getEnvOrDie "NAMESPACE"

69+ creation_cmd <- coerce . pack <$> getEnvOrDie "CREATION_COMMAND"

70+ update_cmd <- coerce . pack <$> getEnvOrDie "UPDATE_COMMAND"

71+ update_envs_cmd <- coerce . pack <$> getEnvOrDie "UPDATE_ENVS_COMMAND"

72+ deletion_cmd <- coerce . pack <$> getEnvOrDie "DELETION_COMMAND"

73+ checking_cmd <- coerce . pack <$> getEnvOrDie "CHECKING_COMMAND"

7374 pgPool <- initConnectionPool (unDBConnectionString $ dmsDB opts) (unDBPoolSize $ dmsDBPoolSize opts)

74− let app' = app $ AppState pgPool

75− logger'

76− proj_name

77− domain

78− ns

79− creation_cmd

80− update_cmd

81− update_envs_cmd

82− deletion_cmd

83− checking_cmd

84− serverPort = dmsPort opts

75+ let app' = app $ AppState pgPool

76+ logger'

77+ proj_name

78+ domain

79+ ns

80+ creation_cmd

81+ update_cmd

82+ update_envs_cmd

83+ deletion_cmd

84+ checking_cmd

85+ serverPort = dmsPort opts

8586 uiServerPort = unServerPort $ dmsUIPort opts

86− tlsOpts = createTLSOpts (dmsTLSCertPath opts) (dmsTLSKeyPath opts) (dmsTLSStorePath opts) serverPort

87− warpOpts = setPort (unServerPort serverPort) defaultSettings

87+ tlsOpts = createTLSOpts (dmsTLSCertPath opts) (dmsTLSKeyPath opts) (dmsTLSStorePath opts) serverPort

88+ warpOpts = setPort (unServerPort serverPort) defaultSettings

8889 in (run uiServerPort app') `race_` (runTLS tlsOpts warpOpts app')

8990

9091initConnectionPool :: ByteString -> Int -> IO PgPool

@@ -105,39 +106,40 @@ server = (listH :<|> createH :<|> getH :<|> editH

105106

106107listH :: AppM [DeploymentFullInfo]

107108listH = do

108− AppState{pool = p, logger = l, base_domain = d} <- ask

109+ AppState {pool = p, logger = l, base_domain = d} <- ask

109110

110111 retrieved <- liftIO $ withResource p $ \conn -> query_ conn q

111− ds <- liftIO $ for retrieved $ \(n, t, e, ct, ut) -> do

112+ deployments <- liftIO $ for retrieved $ \(n, t, e, ct, ut) -> do

112113 es <- parseEnvs (lines e)

113114 pure $ DeploymentFullInfo (Deployment n t es) ct ut (depUrls d n)

114115

115− liftIO . logInfo l $ "get deployments: " <> (pack . show $ ds)

116− return ds

116+ liftIO . logInfo l $ "get deployments: " <> (pack . show $ deployments)

117+ return deployments

117118 where

118− q = "SELECT name, tag, envs, extract(epoch from created_at)::int, extract(epoch from updated_at)::int \

119− \FROM deployments ORDER BY name"

120− depUrls d n = [ ("app", appUrl d n)

121− , ("kibana", "kibana." <> appUrl d n)

122− , ("tasker", "tasker." <> appUrl d n)

123− ]

124− appUrl d n = coerce n <> "." <> coerce d

119+ q =

120+ "SELECT name, tag, envs, extract(epoch from created_at)::int, extract(epoch from updated_at)::int \

121+ \FROM deployments ORDER BY name"

122+ depUrls domain dName = [ ("app", appUrl domain dName)

123+ , ("kibana", "kibana." <> appUrl domain dName)

124+ , ("tasker", "tasker." <> appUrl domain dName)

125+ ]

126+ appUrl domain dName = coerce dName <> "." <> coerce domain

125127

126128createH :: Deployment -> AppM NoContent

127129createH dep = do

128130 st <- ask

129131 let

130132 log :: Text -> IO ()

131− log = logInfo (logger st)

132− pgPool = pool st

133− args = [ "--project-name", coerce $ project_name st

134− , "--base-domain", coerce $ base_domain st

135− , "--namespace", coerce $ namespace st

136− , "--name", coerce $ name dep

137− , "--tag", coerce $ tag dep

138− ]

139− ++ concat [["--env", concatPair e] | e <- envs dep]

140− cmd = coerce $ creation_command st

133+ log = logInfo (logger st)

134+ pgPool = pool st

135+ args =

136+ [ "--project-name", coerce $ project_name st

137+ , "--base-domain", coerce $ base_domain st

138+ , "--namespace", coerce $ namespace st

139+ , "--name", coerce $ name dep

140+ , "--tag", coerce $ tag dep

141+ ] ++ concat [["--env", concatPair e] | e <- envs dep]

142+ cmd = coerce $ creation_command st

141143 createDeployment :: PgPool -> Deployment -> IO Int64

142144 createDeployment p Deployment { name = n, tag = t, envs = e } =

143145 withResource p $ \conn -> execute

@@ -208,9 +210,8 @@ editH n e = do

208210 , "--namespace", coerce $ namespace st

209211 , "--name", coerce n

210212 , "--tag", coerce t

211− ]

212− ++ concat [["--env", concatPair p] | p <- e]

213− cmd = coerce $ update_command st

213+ ] ++ concat [["--env", concatPair p] | p <- e]

214+ cmd = coerce $ update_command st

214215 liftIO $ do

215216 void $ updateEditDeployment pgPool

216217 log $ "call " <> unwords (cmd : args)

@@ -222,13 +223,13 @@ editH n e = do

222223 createDeploymentLog pgPool dep "edit" ec

223224 handleExitCode ec

224225 return ()

225− _ -> liftIO . logWarning (logger st) $ "tag not found, name: " <> coerce n

226+ _ -> liftIO . logWarning (logger st) $ "tag not found, name: " <> coerce n

226227 return NoContent

227228 where

228− getTag :: PgPool -> IO [DeploymentTag]

229− getTag p = fmap (fmap fromOnly) $ withResource p $ \conn ->

229+ getTag :: PgPool -> IO [DeploymentTag]

230+ getTag p = fmap (fmap fromOnly) $ withResource p $ \conn ->

230231 query conn "SELECT tag FROM deployments WHERE name = ?" (Only n)

231− updateEditDeployment :: PgPool -> IO Int64

232+ updateEditDeployment :: PgPool -> IO Int64

232233 updateEditDeployment p = withResource p $ \conn -> execute

233234 conn

234235 "UPDATE deployments SET envs = ?, updated_at = now() WHERE name = ?"

@@ -241,11 +242,11 @@ destroyH dName = do

241242 let

242243 log = logInfo (logger st)

243244 pgPool = pool st

244− args = [ "--project-name", coerce $ project_name st

245− , "--namespace", coerce $ namespace st

246− , "--name", coerce dName

247− ]

248− cmd = coerce $ deletion_command st

245+ args = [ "--project-name", coerce $ project_name st

246+ , "--namespace", coerce $ namespace st

247+ , "--name", coerce dName

248+ ]

249+ cmd = coerce $ deletion_command st

249250 liftIO $ do

250251 log $ "call " <> unwords (cmd : args)

251252 ec <- withProcessWait (proc (unpack cmd) (unpack <$> args)) waitProcess

@@ -276,15 +277,14 @@ updateH dName dTag = do

276277 storedEnv : _ -> do

277278 envPairs <- liftIO $ parseEnvs $ lines storedEnv

278279 let

279− log = logInfo (logger st)

280+ log = logInfo (logger st)

280281 args = [ "--project-name", coerce $ project_name st

281282 , "--base-domain", coerce $ base_domain st

282283 , "--namespace", coerce $ namespace st

283284 , "--name", coerce $ dName

284285 , "--tag", coerce $ dTag

285− ]

286− ++ concat [["--env", concatPair e] | e <- envPairs]

287− cmd = coerce $ update_envs_command st

286+ ] ++ concat [["--env", concatPair e] | e <- envPairs]

287+ cmd = coerce $ update_envs_command st

288288 liftIO $ do

289289 void $ updateDeploymentNameAndTag pgPool dName dTag

290290 log $ "call " <> unwords (cmd : args)

@@ -317,8 +317,7 @@ updateDeploymentNameAndTag p dName dTag = withResource p $ \conn -> execute

317317infoH :: DeploymentName -> AppM [DeploymentInfo]

318318infoH dName = do

319319 st <- ask

320− let

321− pgPool = pool st

320+ let pgPool = pool st

322321 liftIO $ do

323322 dep <- selectDeployment pgPool dName

324323 depLogs <- selectDeploymentLogs pgPool dName

@@ -329,17 +328,18 @@ infoH dName = do

329328pingH :: AppM NoContent

330329pingH = do

331330 pgPool <- pool <$> ask

332− _ :: [Only Int] <-

333− liftIO $ withResource pgPool $ \conn -> query_ conn "SELECT 1"

331+ _ :: [Only Int] <- liftIO $ withResource pgPool $ \conn -> query_ conn "SELECT 1"

334332 pure NoContent

335333

336334statusH :: DeploymentName -> AppM DeploymentStatus

337335statusH dName = do

338336 cmd <- checking_command <$> ask

339− ec <- liftIO $ withProcessWait (proc (unpack $ coerce cmd) [unpack . coerce $ dName]) waitProcess

340− pure $ DeploymentStatus $ case ec of

341− ExitSuccess -> Ok

342− _ -> Error

337+ let args = [unpack . coerce $ dName]

338+ ec <- liftIO $ withProcessWait (proc (unpack $ coerce cmd) args) waitProcess

339+ pure . DeploymentStatus $

340+ case ec of

341+ ExitSuccess -> Ok

342+ _ -> Error

343343

344344waitProcess :: (Show o, Show e) => Process i o e -> IO ExitCode

345345waitProcess p = do

@@ -348,7 +348,7 @@ waitProcess p = do

348348 waitExitCode p

349349

350350handleExitCode :: ExitCode -> IO ()

351−handleExitCode ExitSuccess = return ()

351+handleExitCode ExitSuccess = return ()

352352handleExitCode (ExitFailure c) = throwIO $ DeploymentFailed c

353353

354354createDeploymentLog :: PgPool -> Deployment -> Action -> ExitCode -> IO ()

src/DMS/Args.hs+14−16

@@ -10,29 +10,27 @@ import Types

1010

1111

1212data Args = Args

13− { port :: Int

14− , uiPort :: Int

15− , db :: ByteString

16− , dbPoolSize :: Int

17− , tlsCertPath :: ByteString

18− , tlsKeyPath :: ByteString

13+ { port :: Int

14+ , uiPort :: Int

15+ , db :: ByteString

16+ , dbPoolSize :: Int

17+ , tlsCertPath :: ByteString

18+ , tlsKeyPath :: ByteString

1919 , tlsStorePath :: ByteString

20− }

21− deriving (Generic, Show)

20+ } deriving (Generic, Show)

2221

2322instance ParseRecord Args where

2423 parseRecord = parseRecordWithModifiers lispCaseModifiers

2524

2625data DMSOpts = DMSOpts

27− { dmsPort :: ServerPort

28− , dmsUIPort :: ServerPort

29− , dmsDB :: DBConnectionString

30− , dmsDBPoolSize :: DBPoolSize

31− , dmsTLSCertPath :: TLSCertPath

32− , dmsTLSKeyPath :: TLSKeyPath

26+ { dmsPort :: ServerPort

27+ , dmsUIPort :: ServerPort

28+ , dmsDB :: DBConnectionString

29+ , dmsDBPoolSize :: DBPoolSize

30+ , dmsTLSCertPath :: TLSCertPath

31+ , dmsTLSKeyPath :: TLSKeyPath

3332 , dmsTLSStorePath :: TLSStorePath

34− }

35− deriving (Show)

33+ } deriving (Show)

3634

3735parseArgs :: IO DMSOpts

3836parseArgs = do

src/DMS/Kubernetes.hs+4−3

@@ -33,7 +33,7 @@ kubectlPath :: IO (Maybe FilePath)

3333kubectlPath = findExecutable "kubectl"

3434

3535appChartName, infraChartName :: ChartName

36−appChartName = "b2b-dm-staging"

36+appChartName = "b2b-dm-staging"

3737infraChartName = "b2b-infra-dm-staging"

3838

3939namespace :: Text

@@ -68,7 +68,8 @@ composeAppArgs dName dTag envPairs = [

6868 ]

6969 ++ mconcat (fmap (\a -> ["--set", a]) $ concatPairWithAppEnv <$> envPairs)

7070 ++ [taggedRelease appChartName dTag]

71− where rn = releaseName infraChartName dName

71+ where

72+ rn = releaseName infraChartName dName

7273

7374createInfraArgs :: DeploymentName -> [Text]

7475createInfraArgs dName = [

@@ -95,7 +96,7 @@ composeDestroyArgs chartName dName =

9596 ["delete", releaseName chartName dName, "--purge"]

9697

9798destroyAppArgs, destroyInfraArgs :: DeploymentName -> [CommandArg]

98−destroyAppArgs = composeDestroyArgs appChartName

99+destroyAppArgs = composeDestroyArgs appChartName

99100destroyInfraArgs = composeDestroyArgs infraChartName

100101

101102deletePVCArgs :: DeploymentName -> [CommandArg]

src/TLS.hs+36−35

@@ -2,23 +2,23 @@ module TLS where

44import qualified Data.ByteString.Char8 as BSC

5−import Data.Default.Class (def)

6−import Data.X509 (ExtKeyUsagePurpose(..), HashALG(HashSHA256))

7−import Data.X509.CertificateStore (readCertificateStore)

8−import Data.X509.Validation

5+import Data.Default.Class (def)

6+import Data.X509 (ExtKeyUsagePurpose(..), HashALG(HashSHA256))

7+import Data.X509.CertificateStore (readCertificateStore)

8+import Data.X509.Validation

99 (ValidationChecks(..), ValidationHooks(..), checkLeafV3, validate)

10−import Network.Connection

11−import Network.HTTP.Client

10+import Network.Connection

11+import Network.HTTP.Client

1212 ( Manager, managerResponseTimeout, newManager

1313 , responseTimeoutMicro)

14−import Network.HTTP.Client.TLS

15−import Network.TLS

14+import Network.HTTP.Client.TLS

15+import Network.TLS

1616 ( CertificateRejectReason(..), CertificateUsage(..), ClientHooks(..)

1717 , clientHooks, clientSupported, credentialLoadX509, defaultParamsClient

1818 , onClientCertificate, supportedCiphers)

19−import Network.TLS.Extra.Cipher

19+import Network.TLS.Extra.Cipher

2020import qualified Network.Wai.Handler.WarpTLS as WTLS

21−import Network.Wai.Handler.WarpTLS hiding (TLSSettings, tlsSettings)

21+import Network.Wai.Handler.WarpTLS hiding (TLSSettings, tlsSettings)

2222

2323

2424import Types

@@ -28,51 +28,52 @@ createTLSOpts :: TLSCertPath -> TLSKeyPath -> TLSStorePath -> ServerPort -> WTLS

2828createTLSOpts tlsCert tlsKey tlsStore serverPort

2929 = initTLSSettings

3030 { tlsWantClientCert = True

31− , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

32− , tlsServerHooks = def { onClientCertificate =

31+ , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."

32+ , tlsServerHooks = def { onClientCertificate =

3333 fmap certificateUsageFromValidations . validateCertificate }

3434 }

3535 where

36− tlsCert' = unTLSCertPath tlsCert

37− tlsKey' = unTLSKeyPath tlsKey

38− tlsStore' = BSC.unpack . unTLSStorePath $ tlsStore

39− serverPort' = unServerPort serverPort

40− initTLSSettings = WTLS.tlsSettings (BSC.unpack tlsCert') (BSC.unpack tlsKey')

36+ tlsCert' = unTLSCertPath tlsCert

37+ tlsKey' = unTLSKeyPath tlsKey

38+ tlsStore' = BSC.unpack . unTLSStorePath $ tlsStore

39+ serverPort' = unServerPort serverPort

40+ initTLSSettings = WTLS.tlsSettings

41+ (BSC.unpack tlsCert') (BSC.unpack tlsKey')

4142 certificateUsageFromValidations = maybe CertificateUsageAccept

4243 (CertificateUsageReject . CertificateRejectOther)

43− serviceID = ("localhost", BSC.pack $ show serverPort')

44− validationHooks = def

44+ serviceID = ("localhost", BSC.pack $ show serverPort')

45+ validationHooks = def

4546 { hookValidateName = \_ _ -> [] }

4647 validationChecks = def

4748 { checkStrictOrdering = True

4849 , checkLeafKeyPurpose = [KeyUsagePurpose_ClientAuth]

49− , checkLeafV3 = False

50+ , checkLeafV3 = False

5051 }

51− validateCertificate cert = do

52+ validateCertificate cert = do

5253 mstore <- readCertificateStore tlsStore'

5354 maybe

54− (pure $ Just "Cannot init a store")

55+ (pure . Just $ "Cannot init a store")

5556 (fmap fromX509FailedReasons . (\store -> validate HashSHA256

5657 validationHooks validationChecks store def serviceID cert))

5758 mstore

58− fromX509FailedReasons reasons = case reasons of

59+ fromX509FailedReasons reasons = case reasons of

5960 [] -> Nothing

6061 _ -> Just (show reasons)

6162

6263makeClientManager :: String -> FilePath -> FilePath -> IO Manager

6364makeClientManager dmsHostName cert key = do

64− creds <- either error Just `fmap` credentialLoadX509 cert key

65− let hooks = def

66− { onCertificateRequest = \_ -> return creds

67− , onServerCertificate = \_ _ _ _ -> return []

68− }

69− clientParams = (defaultParamsClient dmsHostName "")

70− { clientHooks = hooks

71− , clientSupported = def { supportedCiphers = ciphersuite_default }

72− }

73− tlsSettings = TLSSettings clientParams

65+ creds <- either error Just <$> credentialLoadX509 cert key

66+ let hooks = def

67+ { onCertificateRequest = \_ -> return creds

68+ , onServerCertificate = \_ _ _ _ -> return []

69+ }

70+ clientParams = (defaultParamsClient dmsHostName "")

71+ { clientHooks = hooks

72+ , clientSupported = def { supportedCiphers = ciphersuite_default }

73+ }

74+ tlsSettings = TLSSettings clientParams

75+ timeout = 20 * 60 * 10 ^ (6 :: Int)

7476 tlsManagerSettings' = (mkManagerSettings tlsSettings Nothing)

75− { managerResponseTimeout =

76− responseTimeoutMicro $ 20 * 60 * 10 ^ (6 :: Int) }

77+ { managerResponseTimeout = responseTimeoutMicro timeout }

7778 in newManager tlsManagerSettings'

7879

src/Types.hs+8−5

@@ -31,7 +31,8 @@ parseEnvs :: [Text] -> IO [(Text, Text)]

3131parseEnvs texts =

3232 for texts $ \t ->

3333 case T.findIndex (== '=') t of

34− Just i -> pure $ bimap strip (T.tail . strip) $ T.splitAt i t -- T.splitAt returns pair with not empty Texts, e.g. ("X", "=Y")

34+ Just i -> pure $ bimap strip (T.tail . strip) $ T.splitAt i t

35+ -- ^ T.splitAt returns pair with not empty Texts, e.g. ("X", "=Y")

3536 Nothing -> error $

3637 "Malformed environment key-value pair " <> T.unpack t <>

3738 ", should be similar to FOO=bar"

@@ -76,14 +77,16 @@ data DeploymentInfo = DeploymentInfo

7677

7778data DeploymentFullInfo = DeploymentFullInfo

7879 { deployment :: Deployment

79− , createdAt :: Int

80− , updatedAt :: Int

81− , urls :: [(Text, Text)]

80+ , createdAt :: Int

81+ , updatedAt :: Int

82+ , urls :: [(Text, Text)]

8283 }

8384 deriving (Generic, Show)

8485 deriving (FromJSON, ToJSON) via Snake DeploymentFullInfo

8586

86−data Status = Ok | Error

87+data Status

88+ = Ok

89+ | Error

8790 deriving (Generic, Show)

8891 deriving (FromJSON, ToJSON) via Snake Status

8992