@@ -4,6 +4,7 @@ import Chronos
44import Control.Lens hiding (List)
55import Control.Monad
66import Data.Coerce
7+import Data.Default.Class (def)
78import Data.Foldable
89import Data.Generics.Product
910import Data.Maybe (fromMaybe)
@@ -11,9 +12,13 @@ import Data.Proxy
1112import Data.Text as T
1213import Data.Text.IO as T
1314import Data.Text.Lens
15+import Network.Connection
1416import Network.HTTP.Client
15− ( defaultManagerSettings, managerResponseTimeout, newManager
17+ ( managerResponseTimeout, newManager
1618 , responseTimeoutMicro)
19+import Network.HTTP.Client.TLS
20+import Network.TLS
21+import Network.TLS.Extra.Cipher
1722import Network.URI
1823import Options.Generic
1924import Prelude as P
@@ -33,12 +38,12 @@ import Types
3338-- | CLI options
3439-- FIXME: add options documentation
3540data Args
36− = Create { name :: Text, tag :: Text, envs :: [Text] }
37− | List
38− | Edit { name :: Text }
39− | Destroy { name :: Text }
40− | Update { name :: Text, tag :: Text }
41− | Info { name :: Text }
41+ = Create { name :: Text, tag :: Text, envs :: [Text], tlsCert :: Maybe Text, tlsKey :: Maybe Text }
42+ | List { tlsCert :: Maybe Text, tlsKey :: Maybe Text }
43+ | Edit { name :: Text, tlsCert :: Maybe Text, tlsKey :: Maybe Text }
44+ | Destroy { name :: Text, tlsCert :: Maybe Text, tlsKey :: Maybe Text }
45+ | Update { name :: Text, tag :: Text, tlsCert :: Maybe Text, tlsKey :: Maybe Text }
46+ | Info { name :: Text, tlsCert :: Maybe Text, tlsKey :: Maybe Text }
4247 deriving stock (Show, Generic)
4348
4449instance ParseRecord Args where
@@ -49,22 +54,41 @@ instance ParseRecord Args where
4954runDMC :: IO ()
5055runDMC = do
5156 args <- getRecord "DMC"
52− manager <- newManager defaultManagerSettings
53− { managerResponseTimeout =
54− responseTimeoutMicro $ 20 * 60 * 10 ^ (6 :: Int) }
57+ let cert = maybe "cert.pem" unpack $ tlsCert args
58+ key = maybe "key.pem" unpack $ tlsKey args
59+ manager <- makeManager cert key
5560 env <- getBaseUrl
5661 let clientEnv = mkClientEnv manager env
5762 case args of
58− Create n t e -> do
63+ Create n t e _ _ -> do
5964 envPairs <- parseEnvs e
6065 handleCreate clientEnv $ Deployment (coerce n) (coerce t) envPairs
61− List -> handleList clientEnv
62− Edit tName -> handleEdit clientEnv $ DeploymentName tName
63− Destroy tName -> handleDestroy clientEnv $ DeploymentName tName
64− Update tName tTag -> handleUpdate clientEnv
66+ List _ _ -> handleList clientEnv
67+ Edit tName _ _ -> handleEdit clientEnv $ DeploymentName tName
68+ Destroy tName _ _ -> handleDestroy clientEnv $ DeploymentName tName
69+ Update tName tTag _ _ -> handleUpdate clientEnv
6570 (DeploymentName tName)
6671 (DeploymentTag tTag)
67− Info tName -> handleInfo clientEnv $ DeploymentName tName
72+ Info tName _ _ -> handleInfo clientEnv $ DeploymentName tName
73+ where
74+ makeManager cert key = do
75+ creds <- either error Just `fmap` credentialLoadX509 cert key
76+ let hooks = def
77+ { onCertificateRequest = \_ -> return creds
78+ , onServerCertificate = \_ _ _ _ -> return []
79+ }
80+ clientParams = (defaultParamsClient dmsHostName "")
81+ { clientHooks = hooks
82+ , clientSupported = def { supportedCiphers = ciphersuite_default }
83+ }
84+ tlsSettings = TLSSettings clientParams
85+ tlsManagerSettings' = (mkManagerSettings tlsSettings Nothing)
86+ { managerResponseTimeout =
87+ responseTimeoutMicro $ 20 * 60 * 10 ^ (6 :: Int) }
88+ in newManager tlsManagerSettings'
89+
90+dmsHostName :: String
91+dmsHostName = "dm.kube.thebestagent.pro"
6892
6993getBaseUrl :: IO BaseUrl
7094getBaseUrl = do
@@ -73,7 +97,7 @@ getBaseUrl = do
7397 let
7498 -- FIXME: unhardcode
7599 defaultBaseUrl :: BaseUrl
76− defaultBaseUrl = BaseUrl Http "dm.kube.thebestagent.pro" 80 ""
100+ defaultBaseUrl = BaseUrl Https dmsHostName 443 ""
77101 parseUrl :: String -> BaseUrl
78102 parseUrl = fromMaybe defaultBaseUrl . parseUrl'
79103 where