{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

{-|

Install [SeaweedFS](https://github.com/seaweedfs/seaweedfs) deployments on a Kubernetes cluster.

-}

module Test.Sandwich.Contexts.Kubernetes.SeaweedFS (
  introduceSeaweedFS

  -- * Bracket-style variants
  , withSeaweedFS
  , withSeaweedFS'

  -- * Types
  , SeaweedFSOptions(..)
  , defaultSeaweedFSOptions

  , seaweedFs
  , SeaweedFSContext(..)
  , HasSeaweedFSContext
  ) where

import Control.Monad
import Data.Aeson as A
import qualified Data.List as L
import Data.String.Interpolate
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Yaml as Yaml
import Relude hiding (withFile)
import System.Exit
import System.FilePath
import Test.Sandwich
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Kubernetes.Images (loadImage')
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 SeaweedFSContext = SeaweedFSContext {
  SeaweedFSContext -> SeaweedFSOptions
seaweedFsOptions :: SeaweedFSOptions
  } deriving (Int -> SeaweedFSContext -> ShowS
[SeaweedFSContext] -> ShowS
SeaweedFSContext -> String
(Int -> SeaweedFSContext -> ShowS)
-> (SeaweedFSContext -> String)
-> ([SeaweedFSContext] -> ShowS)
-> Show SeaweedFSContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SeaweedFSContext -> ShowS
showsPrec :: Int -> SeaweedFSContext -> ShowS
$cshow :: SeaweedFSContext -> String
show :: SeaweedFSContext -> String
$cshowList :: [SeaweedFSContext] -> ShowS
showList :: [SeaweedFSContext] -> ShowS
Show)

data SeaweedFSOptions = SeaweedFSOptions {
  SeaweedFSOptions -> Text
seaweedFsImage :: Text
  , SeaweedFSOptions -> Text
seaweedFsBaseName :: Text
  , SeaweedFSOptions -> Int
seaweedFsMasterReplicas :: Int
  , SeaweedFSOptions -> Int
seaweedFsFilerReplicas :: Int
  , SeaweedFSOptions -> Int
seaweedFsVolumeReplicas :: Int
  , SeaweedFSOptions -> Int
seaweedFsVolumeServerDiskCount :: Int
  , SeaweedFSOptions -> Int
seaweedFsVolumeSizeLimitMb :: Int
  , SeaweedFSOptions -> Text
seaweedFsVolumeStorageRequest :: Text
  } deriving (Int -> SeaweedFSOptions -> ShowS
[SeaweedFSOptions] -> ShowS
SeaweedFSOptions -> String
(Int -> SeaweedFSOptions -> ShowS)
-> (SeaweedFSOptions -> String)
-> ([SeaweedFSOptions] -> ShowS)
-> Show SeaweedFSOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SeaweedFSOptions -> ShowS
showsPrec :: Int -> SeaweedFSOptions -> ShowS
$cshow :: SeaweedFSOptions -> String
show :: SeaweedFSOptions -> String
$cshowList :: [SeaweedFSOptions] -> ShowS
showList :: [SeaweedFSOptions] -> ShowS
Show)
defaultSeaweedFSOptions :: SeaweedFSOptions
defaultSeaweedFSOptions :: SeaweedFSOptions
defaultSeaweedFSOptions = SeaweedFSOptions {
  seaweedFsImage :: Text
seaweedFsImage = Text
"chrislusf/seaweedfs:3.73"
  , seaweedFsBaseName :: Text
seaweedFsBaseName = Text
"seaweed1"
  , seaweedFsMasterReplicas :: Int
seaweedFsMasterReplicas = Int
3
  , seaweedFsFilerReplicas :: Int
seaweedFsFilerReplicas = Int
2
  , seaweedFsVolumeReplicas :: Int
seaweedFsVolumeReplicas = Int
1
  , seaweedFsVolumeServerDiskCount :: Int
seaweedFsVolumeServerDiskCount = Int
1
  , seaweedFsVolumeSizeLimitMb :: Int
seaweedFsVolumeSizeLimitMb = Int
1024
  , seaweedFsVolumeStorageRequest :: Text
seaweedFsVolumeStorageRequest = Text
"2Gi"
  }

seaweedFs :: Label "seaweedFs" SeaweedFSContext
seaweedFs :: Label "seaweedFs" SeaweedFSContext
seaweedFs = Label "seaweedFs" SeaweedFSContext
forall {k} (l :: Symbol) (a :: k). Label l a
Label
type HasSeaweedFSContext context = HasLabel context "seaweedFs" SeaweedFSContext

type ContextWithSeaweedFS context =
  LabelValue "seaweedFs" SeaweedFSContext
  :> LabelValue "file-kubectl" (EnvironmentFile "kubectl")
  :> context

-- | Introduce [SeaweedFS](https://github.com/seaweedfs/seaweedfs) on the Kubernetes cluster, in a given namespace.
introduceSeaweedFS :: (
  KubernetesClusterBasicWithoutReader context m, HasNixContext context
  )
  -- | Namespace
  => Text
  -> SeaweedFSOptions
  -> SpecFree (ContextWithSeaweedFS context) m ()
  -> SpecFree context m ()
introduceSeaweedFS :: forall context (m :: * -> *).
(KubernetesClusterBasicWithoutReader context m,
 HasNixContext context) =>
Text
-> SeaweedFSOptions
-> SpecFree (ContextWithSeaweedFS context) m ()
-> SpecFree context m ()
introduceSeaweedFS Text
namespace SeaweedFSOptions
options = forall (a :: Symbol) context (m :: * -> *).
(HasBaseContext context, HasNixContext context, MonadUnliftIO m,
 KnownSymbol a) =>
Text
-> SpecFree
     (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a)
      :> context)
     m
     ()
-> SpecFree context m ()
introduceBinaryViaNixPackage @"kubectl" Text
"kubectl" (Free
   (SpecCommand
      (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
      m)
   ()
 -> Free (SpecCommand context m) ())
-> (SpecFree (ContextWithSeaweedFS context) m ()
    -> Free
         (SpecCommand
            (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
            m)
         ())
-> SpecFree (ContextWithSeaweedFS context) m ()
-> Free (SpecCommand context m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Label "seaweedFs" SeaweedFSContext
-> ((HasCallStack =>
     SeaweedFSContext
     -> ExampleT
          (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
          m
          [Result])
    -> ExampleT
         (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
         m
         ())
-> SpecFree (ContextWithSeaweedFS context) m ()
-> Free
     (SpecCommand
        (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
        m)
     ()
forall (l :: Symbol) intro context (m :: * -> *).
HasCallStack =>
String
-> Label l intro
-> ((HasCallStack => intro -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduceWith String
"introduce SeaweedFS" Label "seaweedFs" SeaweedFSContext
seaweedFs (ExampleT
  (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
  m
  [Result]
-> ExampleT
     (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
     m
     ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExampleT
   (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
   m
   [Result]
 -> ExampleT
      (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
      m
      ())
-> ((SeaweedFSContext
     -> ExampleT
          (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
          m
          [Result])
    -> ExampleT
         (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
         m
         [Result])
-> (SeaweedFSContext
    -> ExampleT
         (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
         m
         [Result])
-> ExampleT
     (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
     m
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> SeaweedFSOptions
-> (SeaweedFSContext
    -> ExampleT
         (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
         m
         [Result])
-> ExampleT
     (LabelValue "file-kubectl" (EnvironmentFile "kubectl") :> context)
     m
     [Result]
forall context (m :: * -> *) a.
(HasCallStack, MonadFail m, KubectlBasic context m,
 HasNixContext context) =>
Text -> SeaweedFSOptions -> (SeaweedFSContext -> m a) -> m a
withSeaweedFS Text
namespace SeaweedFSOptions
options)

-- | Bracket-style version of 'introduceSeaweedFS'.
withSeaweedFS :: forall context m a. (
  HasCallStack, MonadFail m, KubectlBasic context m, HasNixContext context
  )
  -- | Namespace
  => Text
  -> SeaweedFSOptions
  -> (SeaweedFSContext -> m a)
  -> m a
withSeaweedFS :: forall context (m :: * -> *) a.
(HasCallStack, MonadFail m, KubectlBasic context m,
 HasNixContext context) =>
Text -> SeaweedFSOptions -> (SeaweedFSContext -> m a) -> m a
withSeaweedFS Text
namespace SeaweedFSOptions
options SeaweedFSContext -> m a
action = do
  kcc <- Label "kubernetesCluster" KubernetesClusterContext
-> m KubernetesClusterContext
forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, MonadReader context m) =>
Label l a -> m a
getContext Label "kubernetesCluster" KubernetesClusterContext
kubernetesCluster
  kubectlBinary <- askFile @"kubectl"
  withSeaweedFS' kcc kubectlBinary namespace options action

-- | Same as 'withSeaweedFS', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary path.
withSeaweedFS' :: forall context m a. (
  HasCallStack, MonadFail m, NixContextBasic context m
  )
  -- | Cluster context
  => KubernetesClusterContext
  -- | Path to @kubectl@ binary
  -> FilePath
  -- | Namespace
  -> Text
  -> SeaweedFSOptions
  -> (SeaweedFSContext -> m a)
  -> m a
withSeaweedFS' :: forall context (m :: * -> *) a.
(HasCallStack, MonadFail m, NixContextBasic context m) =>
KubernetesClusterContext
-> String
-> Text
-> SeaweedFSOptions
-> (SeaweedFSContext -> m a)
-> m a
withSeaweedFS' kcc :: KubernetesClusterContext
kcc@(KubernetesClusterContext {String
kubernetesClusterKubeConfigPath :: String
kubernetesClusterKubeConfigPath :: KubernetesClusterContext -> String
kubernetesClusterKubeConfigPath}) String
kubectlBinary Text
namespace SeaweedFSOptions
options SeaweedFSContext -> m a
action = do
  baseEnv <- m [(String, String)]
forall (m :: * -> *). MonadIO m => m [(String, String)]
getEnvironment

  NixContext {..} <- getContext nixContext

  let cp = String -> [String] -> CreateProcess
proc String
nixContextNixBinary [
        String
"build", String
"--impure"
        , String
"--extra-experimental-features", String
"nix-command"
        , String
"--expr", String
seaweedFsOperatorDerivation
        , String
"--no-link"
        , String
"--json"
        ]

  operatorJson <- withFile "/dev/null" WriteMode $ \Handle
hNull ->
    CreateProcess -> String -> m String
forall (m :: * -> *).
MonadIO m =>
CreateProcess -> String -> m String
readCreateProcess (CreateProcess
cp { std_err = UseHandle hNull }) String
""

  operatorPath <- case A.eitherDecodeStrict (encodeUtf8 operatorJson) of
    Right (A.Array (Array -> [Value]
forall a. Vector a -> [a]
V.toList -> ((A.Object (Text -> Object -> Maybe Value
forall v. Text -> KeyMap v -> Maybe v
aesonLookup Text
"outputs" -> Just (A.Object (Text -> Object -> Maybe Value
forall v. Text -> KeyMap v -> Maybe v
aesonLookup Text
"out" -> Just (A.String Text
p))))):[Value]
_))) -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
p
    Either String Value
x -> String -> m Text
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't parse seaweedfs-operator path: #{x}|]

  info [i|Got operator path: #{operatorPath}|]

  -- Build a Nix environment with some tools needed by the operator
  nixEnvPath <- buildNixSymlinkJoin ["coreutils", "gnumake", "go", "stdenv", "which"]
  info [i|Built Nix environment for operator builds: #{nixEnvPath}|]

  let originalSearchPathParts = [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
splitSearchPath (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup String
"PATH" [(String, String)]
baseEnv)
  let finalPath = (String
nixEnvPath String -> ShowS
</> String
"bin") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS
takeDirectory String
kubectlBinary String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
originalSearchPathParts
                [String] -> ([String] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
forall a. ToText a => a -> Text
toText
                [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Text
T.intercalate (String -> Text
forall a. ToText a => a -> Text
toText [Char
searchPathSeparator])
                Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
forall a. ToString a => a -> String
toString

  let env = [(String, String)]
baseEnv
          [(String, String)]
-> ([(String, String)] -> [(String, String)]) -> [(String, String)]
forall a b. a -> (a -> b) -> b
& ((String
"KUBECONFIG", String
kubernetesClusterKubeConfigPath) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:)
          [(String, String)]
-> ([(String, String)] -> [(String, String)]) -> [(String, String)]
forall a b. a -> (a -> b) -> b
& ((String
"PATH", String
finalPath) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:)
          [(String, String)]
-> ([(String, String)] -> [(String, String)]) -> [(String, String)]
forall a b. a -> (a -> b) -> b
& ((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (\(String, String)
x (String, String)
y -> (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
y)

  withSystemTempDirectory "seaweedfs-operator" $ \String
dir -> do
    let target :: String
target = String
dir String -> ShowS
</> String
"seaweefs-operator"
    _ <- CreateProcess -> String -> m String
forall (m :: * -> *).
MonadIO m =>
CreateProcess -> String -> m String
readCreateProcess (String -> [String] -> CreateProcess
proc String
"cp" [String
"-r", Text -> String
forall a. ToString a => a -> String
toString Text
operatorPath, String
target]) String
""
    _ <- readCreateProcess (proc "chmod" ["-R", "u+w", target]) ""

    let runOperatorCmd String
cmd [(String, String)]
extraEnv = CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging (
          (String -> CreateProcess
shell String
cmd) {
              env = Just (env <> extraEnv)
              , cwd = Just target
              }
          ) m ProcessHandle -> (ProcessHandle -> m ExitCode) -> m ExitCode
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess m ExitCode -> (ExitCode -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ExitCode -> ExitCode -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Eq a, Show a) =>
a -> a -> m ()
`shouldBe` ExitCode
ExitSuccess)

    info [i|------------------ Building and uploading SeaweedFS Docker image ------------------|]

    let initialImageName = Text
"seaweedfs/seaweedfs-operator:v0.0.1"

    info [i|Doing make docker-build|]
    runOperatorCmd "make docker-build" [("IMG", toString initialImageName)]

    newImageName <- loadImage' kcc (ImageLoadSpecDocker initialImageName IfNotPresent)
    info [i|Loaded image into cluster as: #{newImageName}|]

    info [i|------------------ Installing SeaweedFS operator ------------------|]

    info [i|Doing make install|]
    runOperatorCmd "make install" [("IMG", toString newImageName)]
    info [i|Doing make deploy|]
    runOperatorCmd "make deploy" [("IMG", toString newImageName)]

    info [i|------------------ Creating SeaweedFS deployment ------------------|]

    let val = ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> SeaweedFSOptions -> Value
example Text
namespace SeaweedFSOptions
options
    createProcessWithLoggingAndStdin ((shell [i|#{kubectlBinary} create -f -|]) { env = Just env }) val
      >>= waitForProcess >>= (`shouldBe` ExitSuccess)

    action $ SeaweedFSContext {
      seaweedFsOptions = options
      }


example :: Text -> SeaweedFSOptions -> Yaml.Value
example :: Text -> SeaweedFSOptions -> Value
example Text
namespace (SeaweedFSOptions {Int
Text
seaweedFsImage :: SeaweedFSOptions -> Text
seaweedFsBaseName :: SeaweedFSOptions -> Text
seaweedFsMasterReplicas :: SeaweedFSOptions -> Int
seaweedFsFilerReplicas :: SeaweedFSOptions -> Int
seaweedFsVolumeReplicas :: SeaweedFSOptions -> Int
seaweedFsVolumeServerDiskCount :: SeaweedFSOptions -> Int
seaweedFsVolumeSizeLimitMb :: SeaweedFSOptions -> Int
seaweedFsVolumeStorageRequest :: SeaweedFSOptions -> Text
seaweedFsImage :: Text
seaweedFsBaseName :: Text
seaweedFsMasterReplicas :: Int
seaweedFsFilerReplicas :: Int
seaweedFsVolumeReplicas :: Int
seaweedFsVolumeServerDiskCount :: Int
seaweedFsVolumeSizeLimitMb :: Int
seaweedFsVolumeStorageRequest :: Text
..}) = let Right Value
x = ByteString -> Either ParseException Value
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
raw in Value
x
 where raw :: ByteString
raw = [i|apiVersion: seaweed.seaweedfs.com/v1
kind: Seaweed
metadata:
  namespace: #{namespace}
  name: #{seaweedFsBaseName}
spec:
  image: #{seaweedFsImage}
  volumeServerDiskCount: #{seaweedFsVolumeServerDiskCount}
  hostSuffix: seaweed.abcdefg.com
  master:
    replicas: #{seaweedFsMasterReplicas}
    volumeSizeLimitMB: #{seaweedFsVolumeSizeLimitMb}
  volume:
    replicas: #{seaweedFsVolumeReplicas}
    requests:
      storage: #{seaweedFsVolumeStorageRequest}
  filer:
    replicas: #{seaweedFsFilerReplicas}
    config: |
      [leveldb2]
      enabled = true
      dir = "/data/filerldb2"
|]

seaweedFsOperatorDerivation :: String
seaweedFsOperatorDerivation = [__i|with import <nixpkgs> {}; fetchFromGitHub {
                                     owner = "seaweedfs";
                                     repo = "seaweedfs-operator";
                                     rev = "6fa4c24d47c57daa10a084e3a5598efbb8d808c8";
                                     sha256 = "sha256-gFFIG2tglzvXoqzUvbzWAG2Bg2RwCCsuX0tXwV95D/0=";
                                   }
                                  |]