content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE TypeOperators #-}
  
  module Test.Sandwich.Contexts.Kubernetes.MinikubeCluster.Images (
    getLoadedImagesMinikube
    , clusterContainsImageMinikube
    , loadImageMinikube
    ) where
  
  import Control.Monad
  import Control.Monad.IO.Unlift
  import Control.Monad.Logger
  import qualified Data.Aeson as A
  import qualified Data.ByteString as B
  import qualified Data.List as L
  import qualified Data.Set as Set
  import Data.String.Interpolate
  import Data.Text as T
  import Relude
  import System.Exit
  import System.FilePath
  import Test.Sandwich
  import Test.Sandwich.Contexts.Kubernetes.Types
  import Test.Sandwich.Contexts.Kubernetes.Util.Images
  import Text.Regex.TDFA
  import UnliftIO.Directory
  import UnliftIO.Process
  import UnliftIO.Temporary
  
  
  -- | Load an image onto a cluster. This image can come from a variety of sources, as specified by the 'ImageLoadSpec'.
  loadImageMinikube :: (
    HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m
    )
    -- | Path to @minikube@ binary
    => FilePath
    -- | Cluster name
    -> Text
    -- | Extra flags to pass to @minikube@
    -> [Text]
    -- | Image load spec
    -> ImageLoadSpec
    -- | Returns transformed image name
    -> m Text
  loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do
    case imageLoadSpec of
      ImageLoadSpecTarball image -> do
        -- File or directory image
        doesDirectoryExist (toString image) >>= \case
          True ->
            -- Uncompressed directory: tar it up (but don't zip).
            -- Formerly we would execute a shell with a pipe to direct the tar output directly into "minikube image load".
            -- But then "minikube image load" would just write its own tarball in /tmp, like /tmp/build.12345.tar, and
            -- leave it there!
            withSystemTempDirectory "image-tarball" $ \tempDir -> do
              let tarFile = tempDir </> "image.tar"
              -- TODO: don't depend on external tar file
              createProcessWithLogging (shell [i|tar -C "#{image}" --dereference --hard-dereference --xform s:'^./':: -c . > "#{tarFile}"|])
                >>= waitForProcess >>= (`shouldBe` ExitSuccess)
              imageLoad tarFile False
              readImageName (toString image)
          False -> case takeExtension (toString image) of
            ".tar" -> do
              imageLoad (toString image) False
              readImageName (toString image)
            ".gz" -> do
              withSystemTempDirectory "image-tarball" $ \tempDir -> do
                let tarFile = tempDir </> "image.tar"
                -- TODO: don't depend on external gzip file
                createProcessWithLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])
                  >>= waitForProcess >>= (`shouldBe` ExitSuccess)
                imageLoad tarFile False
                readImageName (toString image)
            _ -> expectationFailure [i|Unexpected image extension in #{image}. Wanted .tar, .tar.gz, or uncompressed directory.|]
  
      ImageLoadSpecDocker image pullPolicy -> do
        _ <- dockerPullIfNecessary image pullPolicy
        imageLoad (toString image) True >> return image
  
      ImageLoadSpecPodman image pullPolicy -> do
        _ <- podmanPullIfNecessary image pullPolicy
        imageLoad (toString image) True >> return image
  
    where
      imageLoad :: (MonadLoggerIO m, HasCallStack) => String -> Bool -> m ()
      imageLoad toLoad daemon = do
        let extraFlags = case "--rootless" `L.elem` minikubeFlags of
                           True -> ["--rootless"]
                           False -> []
  
        let args = ["image", "load", toLoad
                   , "--profile", toString clusterName
                   , "--logtostderr=true", "--v=1"
                   , [i|--daemon=#{A.encode daemon}|]
                   ] <> extraFlags
  
        debug [i|#{minikubeBinary} #{T.unwords $ fmap toText args}|]
  
        -- Gather stderr output while also logging it
        logFn <- askLoggerIO
        stderrOutputVar <- newIORef mempty
        let customLogFn loc src level str = do
              modifyIORef' stderrOutputVar (<> str)
              logFn loc src level str
  
        liftIO $ flip runLoggingT customLogFn $
          createProcessWithLogging (proc minikubeBinary args)
            >>= waitForProcess >>= (`shouldBe` ExitSuccess)
  
        stderrOutput <- fromLogStr <$> readIORef stderrOutputVar
  
        let ef (details :: Text) = expectationFailure [i|minikube image load failed; error output detected (#{details})|]
  
        when (check1 stderrOutput) $ ef "Contained 'Failed to load cached images for profile' message"
        when (check2 stderrOutput) $ ef "Contained 'ctr: failed to ingest' message"
        when (check3 stderrOutput) $ ef "Contained 'failed pushing to' message"
  
      -- This is crazy, but minikube image load sometimes fails silently.
      -- One example: https://github.com/kubernetes/minikube/issues/16032
      -- As a result, we add a few checks to detect the cases we've seen that represent a failed load.
  
      check1 bytes = "Failed to load cached images for profile" `B.isInfixOf` bytes
                   && "make sure the profile is running." `B.isInfixOf` bytes
  
      check2 bytes = "ctr: failed to ingest" `B.isInfixOf` bytes
                   && "failed to copy: failed to send write: error reading from server: EOF: unavailable" `B.isInfixOf` bytes
  
      check3 :: ByteString -> Bool
      check3 bytes = bytes =~ ("failed pushing to:[[:blank:]]*[^[:space:]]+$" :: Text)
  
  -- | Get the loaded images on a cluster, by cluster name.
  getLoadedImagesMinikube :: (
    MonadUnliftIO m, MonadLogger m
    )
    -- | Path to @minikube@ binary
    => FilePath
    -- | Cluster name
    -> Text
    -- | Extra flags to pass to @minikube@
    -> [Text]
    -> m (Set Text)
  getLoadedImagesMinikube minikubeBinary clusterName minikubeFlags = do
    -- TODO: use "--format json" and parse?
    (Set.fromList . T.words . toText) <$> readCreateProcessWithLogging (
      proc minikubeBinary (["image", "ls"
                           , "--profile", toString clusterName
                           ] <> fmap toString minikubeFlags)) ""
  
  -- | Test if the cluster contains a given image, by cluster name.
  clusterContainsImageMinikube :: (
    MonadUnliftIO m, MonadLogger m
    )
    -- | Path to @minikube@ binary
    => FilePath
    -- | Cluster name
    -> Text
    -- | Extra flags to pass to @minikube@
    -> [Text]
    -- | Image name
    -> Text
    -> m Bool
  clusterContainsImageMinikube minikubeBinary clusterName minikubeFlags image = do
    imageName <- case isAbsolute (toString image) of
      False -> pure image
      True -> readImageName (toString image)
  
    loadedImages <- getLoadedImagesMinikube minikubeBinary clusterName minikubeFlags
  
    return (
      imageName `Set.member` loadedImages
  
      -- Deal with weird prefixing Minikube does; see
      -- https://github.com/kubernetes/minikube/issues/19343
      || ("docker.io/" <> imageName) `Set.member` loadedImages
      || ("docker.io/library/" <> imageName) `Set.member` loadedImages
      )
  