sandwich-contexts-kubernetes: basic Longhorn installation works

2024-10-03 23:08:04 +03:00 · 2024-06-26 20:30:13 -07:00 · 2024-06-26 20:30:13 -07:00 · cf6c65f97c
commit cf6c65f97c
parent 1f0a0458ab
9 changed files with 189 additions and 23 deletions
--- a/demos/demo-kubernetes-longhorn/.gitignore
+++ b/demos/demo-kubernetes-longhorn/.gitignore
@ -0,0 +1,2 @@
+.stack-work/
+*~
--- a/demos/demo-kubernetes-longhorn/LICENSE
+++ b/demos/demo-kubernetes-longhorn/LICENSE
@ -0,0 +1,30 @@
+Copyright Tom McLaughlin (c) 2023
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Tom McLaughlin nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- a/demos/demo-kubernetes-longhorn/app/Main.hs
+++ b/demos/demo-kubernetes-longhorn/app/Main.hs
@ -0,0 +1,52 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Main where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.List as L
+import Data.String.Interpolate
+import Data.Time
+import Relude
+import System.Exit
+import Test.Sandwich
+import Test.Sandwich.Contexts.FakeSmtpServer
+import Test.Sandwich.Contexts.Files
+import Test.Sandwich.Contexts.Kubernetes.Longhorn
+import Test.Sandwich.Contexts.Kubernetes.MinikubeCluster
+import Test.Sandwich.Contexts.Kubernetes.MinioOperator
+import Test.Sandwich.Contexts.Kubernetes.MinioS3Server
+import Test.Sandwich.Contexts.Kubernetes.Namespace
+import Test.Sandwich.Contexts.Nix
+import Test.Sandwich.Contexts.Waits
+import UnliftIO.Concurrent
+import UnliftIO.Environment
+import UnliftIO.Process
+
+
+spec :: TopSpec
+spec = describe "Introducing a Kubernetes cluster" $ do
+  describe "Via Minikube" $ do
+    introduceNixContext nixpkgsReleaseDefault $ do
+      introduceMinikubeClusterViaNix defaultMinikubeClusterOptions $ do
+        it "prints the cluster info" $ do
+          kcc <- getContext kubernetesCluster
+          info [i|Got Kubernetes cluster context: #{kcc}|]
+
+        introduceLonghorn defaultLonghornOptions $ do
+          it "Has a Longhorn context" $ do
+            x <- getContext longhorn
+            info [i|Got Longhorn context: #{x}|]
+
+          it "Pauses for 5 minutes for examination" $ do
+            kcc <- getContext kubernetesCluster
+            debug [i|export KUBECONFIG='#{kubernetesClusterKubeConfigPath kcc}'|]
+            threadDelay 300_000_000
+
+
+main :: IO ()
+main = runSandwichWithCommandLineArgs defaultOptions spec
--- a/demos/demo-kubernetes-longhorn/demo-kubernetes-longhorn.cabal
+++ b/demos/demo-kubernetes-longhorn/demo-kubernetes-longhorn.cabal
@ -0,0 +1,42 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.36.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           demo-kubernetes-longhorn
+version:        0.1.0.0
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+
+executable demo-kubernetes-longhorn
+  main-is: Main.hs
+  other-modules:
+      Paths_demo_kubernetes_longhorn
+  hs-source-dirs:
+      app
+  default-extensions:
+      OverloadedStrings
+      QuasiQuotes
+      NamedFieldPuns
+      RecordWildCards
+      ScopedTypeVariables
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base
+    , bytestring
+    , monad-logger
+    , network
+    , relude
+    , sandwich
+    , sandwich-contexts
+    , sandwich-contexts-kubernetes
+    , string-interpolate
+    , text
+    , time
+    , unliftio
+  default-language: Haskell2010
--- a/demos/demo-kubernetes-longhorn/package.yaml
+++ b/demos/demo-kubernetes-longhorn/package.yaml
@ -0,0 +1,37 @@
+name:                demo-kubernetes-longhorn
+version:             0.1.0.0
+license:             BSD3
+
+dependencies:
+- base
+- bytestring
+- monad-logger
+- network
+- relude
+- sandwich
+- sandwich-contexts
+- sandwich-contexts-kubernetes
+- string-interpolate
+- text
+- time
+- unliftio
+
+default-extensions:
+- OverloadedStrings
+- QuasiQuotes
+- NamedFieldPuns
+- RecordWildCards
+- ScopedTypeVariables
+- FlexibleContexts
+- FlexibleInstances
+- LambdaCase
+
+ghc-options:
+- -threaded
+- -rtsopts
+- -with-rtsopts=-N
+
+executables:
+  demo-kubernetes-longhorn:
+    main: Main.hs
+    source-dirs: app
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs
@ -23,21 +23,15 @@ module Test.Sandwich.Contexts.Kubernetes.Longhorn (
 import Control.Monad
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
-import Data.Aeson as A
 import qualified Data.List as L
-import Data.String.Interpolate
-import qualified Data.Vector as V
 import Relude hiding (withFile)
 import System.Exit
-import System.FilePath
 import Test.Sandwich
-import Test.Sandwich.Contexts.Kubernetes.Images (loadImage')
+import Test.Sandwich.Contexts.Files
 import Test.Sandwich.Contexts.Kubernetes.Types
-import Test.Sandwich.Contexts.Kubernetes.Util.Aeson
+import Test.Sandwich.Contexts.Nix
 import UnliftIO.Environment
-import UnliftIO.IO (withFile)
 import UnliftIO.Process
-import UnliftIO.Temporary


 data LonghornContext = LonghornContext {
@ -45,11 +39,11 @@ data LonghornContext = LonghornContext {
  } deriving (Show)

 data LonghornOptions = LonghornOptions {
-  longhornFoo :: ()
+  longhornYaml :: String
  } deriving (Show)
 defaultLonghornOptions :: LonghornOptions
 defaultLonghornOptions = LonghornOptions {
-  longhornFoo = ()
+  longhornYaml = "https://raw.githubusercontent.com/longhorn/longhorn/v1.6.2/deploy/longhorn.yaml"
  }

 longhorn :: Label "longhorn" LonghornContext
@ -57,22 +51,29 @@ longhorn = Label
 type HasLonghornContext context = HasLabel context "longhorn" LonghornContext

 introduceLonghorn :: (
-  HasBaseContext context, HasKubernetesClusterContext context, MonadUnliftIO m
-  ) =>Text -> LonghornOptions -> SpecFree (LabelValue "longhorn" LonghornContext :> context) m () -> SpecFree context m ()
-introduceLonghorn namespace options = introduceWith "introduce Longhorn" longhorn (void . withLonghorn namespace options)
+  HasBaseContext context, HasKubernetesClusterContext context, MonadUnliftIO m, HasNixContext context
+  ) => LonghornOptions -> SpecFree (LabelValue "longhorn" LonghornContext :> LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context) m () -> SpecFree context m ()
+introduceLonghorn options =
+  introduceBinaryViaNixPackage @"kubectl" "kubectl"
+  . introduceWith "introduce Longhorn" longhorn (void . withLonghorn options)

 withLonghorn :: forall context m a. (
-  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m, HasKubernetesClusterContext context
-  ) => Text -> LonghornOptions -> (LonghornContext -> m a) -> m a
-withLonghorn namespace options action = do
+  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m
+  , HasBaseContextMonad context m, HasKubernetesClusterContext context, HasFile context "kubectl"
+  ) => LonghornOptions -> (LonghornContext -> m a) -> m a
+withLonghorn options action = do
  kcc <- getContext kubernetesCluster
-  withLonghorn' kcc namespace options action
+  kubectlBinary <- askFile @"kubectl"
+  withLonghorn' kcc kubectlBinary options action

-withLonghorn' :: forall context m a. (
-  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
-  ) => KubernetesClusterContext -> Text -> LonghornOptions -> (LonghornContext -> m a) -> m a
-withLonghorn' kcc@(KubernetesClusterContext {kubernetesClusterKubeConfigPath}) namespace options action = do
+withLonghorn' :: forall m a. (
+  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m
+  ) => KubernetesClusterContext -> String -> LonghornOptions -> (LonghornContext -> m a) -> m a
+withLonghorn' (KubernetesClusterContext {kubernetesClusterKubeConfigPath}) kubectlBinary options@(LonghornOptions {..}) action = do
  baseEnv <- getEnvironment
  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)

-  undefined
+  createProcessWithLogging ((proc kubectlBinary ["apply", "-f", longhornYaml]) { env = Just env })
+    >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+
+  action $ LonghornContext options
--- a/sandwich-contexts-kubernetes/package.yaml
+++ b/sandwich-contexts-kubernetes/package.yaml
@ -37,6 +37,7 @@ library:
  - Test.Sandwich.Contexts.Kubernetes.Cluster
  - Test.Sandwich.Contexts.Kubernetes.Images
  - Test.Sandwich.Contexts.Kubernetes.KindCluster
+  - Test.Sandwich.Contexts.Kubernetes.Longhorn
  - Test.Sandwich.Contexts.Kubernetes.MinikubeCluster
  - Test.Sandwich.Contexts.Kubernetes.MinioOperator
  - Test.Sandwich.Contexts.Kubernetes.MinioS3Server
--- a/sandwich-contexts-kubernetes/sandwich-contexts-kubernetes.cabal
+++ b/sandwich-contexts-kubernetes/sandwich-contexts-kubernetes.cabal
@ -18,6 +18,7 @@ library
      Test.Sandwich.Contexts.Kubernetes.Cluster
      Test.Sandwich.Contexts.Kubernetes.Images
      Test.Sandwich.Contexts.Kubernetes.KindCluster
+      Test.Sandwich.Contexts.Kubernetes.Longhorn
      Test.Sandwich.Contexts.Kubernetes.MinikubeCluster
      Test.Sandwich.Contexts.Kubernetes.MinioOperator
      Test.Sandwich.Contexts.Kubernetes.MinioS3Server
@ -33,7 +34,6 @@ library
      Test.Sandwich.Contexts.Kubernetes.KindCluster.Setup
      Test.Sandwich.Contexts.Kubernetes.KubectlLogs
      Test.Sandwich.Contexts.Kubernetes.KubectlPortForward
-      Test.Sandwich.Contexts.Kubernetes.Longhorn
      Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Forwards
      Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images
      Test.Sandwich.Contexts.Kubernetes.MinioS3Server.Parsing
--- a/stack.yaml
+++ b/stack.yaml
@ -39,6 +39,7 @@ packages:
 - ./demos/demo-golden
 - ./demos/demo-hedgehog
 - ./demos/demo-kubernetes-kind
+- ./demos/demo-kubernetes-longhorn
 - ./demos/demo-kubernetes-minikube
 - ./demos/demo-kubernetes-seaweedfs
 - ./demos/demo-landing