-
Notifications
You must be signed in to change notification settings - Fork 2
/
Main.purs
220 lines (198 loc) · 7.77 KB
/
Main.purs
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
81
82
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
208
209
210
211
212
213
214
215
216
217
218
219
220
module Kubernetes.Test.Integration.Main where
import Kubernetes.Api.Batch.V1
import Kubernetes.Api.Core.V1
import Kubernetes.Api.Lens
import Prelude
import Control.Alt ((<|>))
import Control.Monad.Except (runExcept)
import Data.Either (Either(..), either, hush)
import Foreign (MultipleErrors)
import Foreign as Foreign
import Data.Function.Uncurried (Fn3, runFn3)
import Data.HTTP.Method as Method
import Data.Lens
import Data.Lens as L
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (mempty)
import Data.Time.Duration (Milliseconds(..))
import Data.Tuple (Tuple(..))
import Debug.Trace as Debug
import Effect.Aff (Aff, launchAff_, throwError)
import Effect.Aff as Aff
import Effect (Effect)
import Effect.Class (liftEffect)
import Effect.Class.Console (log, logShow)
import Effect.Exception as Exception
import Foreign.Object as Object
import Kubernetes.Api.Core.V1.Namespace as NS
import Kubernetes.Api.Core.V1.Service as Service
import Kubernetes.Api.Extensions.V1Beta1.Deployment as Deploy
import Kubernetes.Api.APIExtensions.V1Beta1 (Deployment(Deployment))
import Kubernetes.Api.Meta.V1 as MetaV1
import Kubernetes.Api.Util (IntOrString(..))
import Kubernetes.Client as Client
import Kubernetes.Config (Config(Config))
import Kubernetes.Config as Cfg
import Kubernetes.Default (default)
import Kubernetes.Request as Request
import Node.Encoding (Encoding(..))
import Node.FS.Aff (readTextFile)
import Node.Process as Process
echoDeployment :: Deployment
echoDeployment =
(default :: Deployment)
# _metadata ?~ (default
# _labels ?~ (Object.fromFoldable
[ Tuple "service" "echoserver" ])
# _name ?~ "echoserver")
# _spec ?~ (default
# _replicas ?~ 1
# _strategy ?~ (default
# _type ?~ "Recreate")
# _template ?~ (default
# _metadata ?~ (default
# _name ?~ "echoserver"
# _labels ?~ Object.fromFoldable
[ Tuple "service" "echoserver" ])
# _spec ?~ ((default :: PodSpec)
# _containers ?~
[ (default :: Container)
# _image ?~ "gcr.io/google_containers/echoserver:1.4"
# _imagePullPolicy ?~ "Always"
# _name ?~ "echo"
# _ports ?~ [ default # _containerPort ?~ 8080 ]]
# _restartPolicy ?~ "Always"
# _terminationGracePeriodSeconds ?~ 30
# _dnsPolicy ?~ "ClusterFirst"
# _schedulerName ?~ "default-scheduler")))
echoService :: Service
echoService =
default
# _metadata ?~ (default
# _labels ?~ (Object.fromFoldable
[ Tuple "service" "echoserver" ])
# _name ?~ "echoserver")
# _spec ?~ (default
# _type ?~ "NodePort"
# _ports ?~ [ default
# _name ?~ "http"
# _protocol ?~ "TCP"
# _port ?~ 9200
# _targetPort ?~ (IntOrStringInt 8080) ]
# _selector ?~ (Object.fromFoldable [ Tuple "service" "echoserver" ]))
testNamespace :: Namespace
testNamespace = default
# _metadata ?~ (default # _name ?~ "test")
-- Example: Without lenses there is a lot of boilerplate
testNamespace2 :: Namespace
testNamespace2 = default # (\(Namespace n) -> Namespace $ n
{ metadata = Just $
default # (\(MetaV1.ObjectMeta m) -> MetaV1.ObjectMeta $ m
{ name = Just "test" }) })
loadConfig :: Aff Config
loadConfig = do
host <- envVar "K8S_HOST"
portStr <- envVar "K8S_PORT"
let port = fromMaybe 80 (portStr >>= parseInt)
protocolStr <- envVar "K8S_PROTOCOL"
let protocol = maybe Request.ProtocolHTTP parseProtocol protocolStr
let cluster = { host: fromMaybe "localhost" host, protocol, port }
caCert <- envVar "CA_CERT" >>= loadFile
clientCert <- envVar "CLIENT_CERT" >>= loadFile
clientKey <- envVar "CLIENT_KEY" >>= loadFile
user <- envVar "BASIC_AUTH_USER"
pass <- envVar "BASIC_AUTH_PASS"
let basicAuth = {user: _, password: _} <$> user <*> pass
bearerTokenFromFile <- envVar "BEARER_TOKEN_FILE" >>= loadFile
bearerTokenInline <- envVar "BEARER_TOKEN"
let bearerToken = bearerTokenFromFile <|> bearerTokenInline
pure $ Config $
{ basicAuth
, bearerToken
, cluster
, tls: {caCert, clientCert, clientKey, verifyServerCert: true} }
where
envVar v = liftEffect (Process.lookupEnv v)
loadFile = maybe (pure mempty) (map Just <<< Cfg.loadFile)
parseProtocol p = if p == "https"
then Request.ProtocolHTTPS
else Request.ProtocolHTTP
podHelloWorld :: Config -> Aff Unit
podHelloWorld cfg = Aff.finally cleanup do
_ <- deleteNs testNs
log "Creating test namespace"
ns <- NS.create cfg testNamespace >>= unwrapEither
log "Creating new deployment"
deployment <- Deploy.createNamespaced cfg testNs echoDeployment >>= unwrapEither
log "Waiting for deployment to be ready"
result <- iterateUntil isReadyDeploy $ shortDelay *> readDeploy cfg testNs "echoserver"
log $ "Deployment ready with status: " <> show (result ^? (L._Right <<< _status))
log "Creating new service"
service <- Service.createNamespaced cfg testNs echoService >>= unwrapEither
case service ^. _spec <<< L._Just <<< _clusterIP of
Just ip -> pingEndpoint ip 9200
Nothing -> throwError $ Exception.error "Failure: No cluster IP on service"
where
cleanup = do
log "Cleaning up"
deleteNs testNs
testNs = "test"
deleteNs ns = do
log $ "Deleting namespace '" <> ns <> "'"
deleteRes <- NS.delete cfg "test" default default
_ <- iterateUntil notFound $ shortDelay *> log "Check: does namespace exist?" *> readNs cfg "test"
log $ "Deleted test namespace with result: " <> show deleteRes
shortDelay = Aff.delay (Milliseconds 500.0)
iterateUntil :: forall a m. Monad m => (a -> Boolean) -> m a -> m a
iterateUntil p x = x >>= iterateUntilM p (const x)
iterateUntilM :: forall m a. Monad m => (a -> Boolean) -> (a -> m a) -> a -> m a
iterateUntilM p f v = if p v then pure v else f v >>= iterateUntilM p f
foreign import parseIntImpl :: Fn3 (Int -> Maybe Int) (Maybe Int) String (Maybe Int)
parseInt :: String -> Maybe Int
parseInt = runFn3 parseIntImpl Just Nothing
readNs :: Config -> String -> Aff (Either MetaV1.Status Namespace)
readNs cfg name = NS.read cfg name default
notFound :: (Either MetaV1.Status Namespace) -> Boolean
notFound = L.preview (L._Left <<< _code <<< L._Just)
>>> maybe false (eq 404)
readDeploy :: Config -> String -> String -> Aff (Either MetaV1.Status Deployment)
readDeploy cfg ns name = Deploy.readNamespaced cfg ns name default
isReadyDeploy :: (Either MetaV1.Status Deployment) -> Boolean
isReadyDeploy = L.preview (L._Right <<< readyReplicas)
>>> maybe false (_ > 0)
hasReadyReplica :: Deployment -> Boolean
hasReadyReplica = L.preview readyReplicas
>>> maybe false (_ > 0)
readyReplicas :: L.Traversal' Deployment Int
readyReplicas = _status <<< L._Just <<< _readyReplicas <<< L._Just
pingEndpoint :: String -> Int -> Aff Unit
pingEndpoint ip port = do
log $ "Ping " <> ip <> ":" <> show port
let req =
{ basicAuth: Nothing
, bearerToken: Nothing
, body: Nothing
, caCert: Nothing
, clientCert: Nothing
, clientKey: Nothing
, host: ip
, port
, protocol: Request.ProtocolHTTP
, method: Method.GET
, path: "/"
, rejectUnauthorized: true }
attempt <- Aff.attempt $ Request.request req
case attempt of
Right res -> do
log "Received valid response from endpoint:"
log res.body
Left e -> do
Aff.delay (Milliseconds 1000.0)
pingEndpoint ip port
unwrapEither :: forall a b. Show a => Either a b -> Aff b
unwrapEither (Left error) = throwError (Exception.error $ show error)
unwrapEither (Right val) = pure val
main :: Effect Unit
main = launchAff_ do
cfg <- loadConfig
podHelloWorld cfg