{-# 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 :: forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m) =>
FilePath -> Text -> [Text] -> ImageLoadSpec -> m Text
loadImageMinikube FilePath
minikubeBinary Text
clusterName [Text]
minikubeFlags ImageLoadSpec
imageLoadSpec = do
  case ImageLoadSpec
imageLoadSpec of
    ImageLoadSpecTarball FilePath
image -> do
      -- File or directory image
      FilePath -> m Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesDirectoryExist (FilePath -> FilePath
forall a. ToString a => a -> FilePath
toString FilePath
image) m Bool -> (Bool -> m Text) -> m Text
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
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!
          FilePath -> (FilePath -> m Text) -> m Text
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"image-tarball" ((FilePath -> m Text) -> m Text) -> (FilePath -> m Text) -> m Text
forall a b. (a -> b) -> a -> b
$ \FilePath
tempDir -> do
            let tarFile :: FilePath
tarFile = FilePath
tempDir FilePath -> FilePath -> FilePath
</> FilePath
"image.tar"
            -- TODO: don't depend on external tar file
            CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging (FilePath -> CreateProcess
shell [i|tar -C "#{image}" --dereference --hard-dereference --xform s:'^./':: -c . > "#{tarFile}"|])
              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)
            FilePath -> Bool -> m ()
forall (m :: * -> *).
(MonadLoggerIO m, HasCallStack) =>
FilePath -> Bool -> m ()
imageLoad FilePath
tarFile Bool
False
            FilePath -> m Text
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
FilePath -> m Text
readImageName (FilePath -> FilePath
forall a. ToString a => a -> FilePath
toString FilePath
image)
        Bool
False -> case FilePath -> FilePath
takeExtension (FilePath -> FilePath
forall a. ToString a => a -> FilePath
toString FilePath
image) of
          FilePath
".tar" -> do
            FilePath -> Bool -> m ()
forall (m :: * -> *).
(MonadLoggerIO m, HasCallStack) =>
FilePath -> Bool -> m ()
imageLoad (FilePath -> FilePath
forall a. ToString a => a -> FilePath
toString FilePath
image) Bool
False
            FilePath -> m Text
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
FilePath -> m Text
readImageName (FilePath -> FilePath
forall a. ToString a => a -> FilePath
toString FilePath
image)
          FilePath
".gz" -> do
            FilePath -> (FilePath -> m Text) -> m Text
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"image-tarball" ((FilePath -> m Text) -> m Text) -> (FilePath -> m Text) -> m Text
forall a b. (a -> b) -> a -> b
$ \FilePath
tempDir -> do
              let tarFile :: FilePath
tarFile = FilePath
tempDir FilePath -> FilePath -> FilePath
</> FilePath
"image.tar"
              -- TODO: don't depend on external gzip file
              CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging (FilePath -> CreateProcess
shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])
                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)
              FilePath -> Bool -> m ()
forall (m :: * -> *).
(MonadLoggerIO m, HasCallStack) =>
FilePath -> Bool -> m ()
imageLoad FilePath
tarFile Bool
False
              FilePath -> m Text
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
FilePath -> m Text
readImageName (FilePath -> FilePath
forall a. ToString a => a -> FilePath
toString FilePath
image)
          FilePath
_ -> FilePath -> m Text
forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
FilePath -> m a
expectationFailure [i|Unexpected image extension in #{image}. Wanted .tar, .tar.gz, or uncompressed directory.|]

    ImageLoadSpecDocker Text
image ImagePullPolicy
pullPolicy -> do
      _ <- Text -> ImagePullPolicy -> m Bool
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Text -> ImagePullPolicy -> m Bool
dockerPullIfNecessary Text
image ImagePullPolicy
pullPolicy
      imageLoad (toString image) True >> return image

    ImageLoadSpecPodman Text
image ImagePullPolicy
pullPolicy -> do
      _ <- Text -> ImagePullPolicy -> m Bool
forall (m :: * -> *).
(MonadUnliftIO m, MonadLoggerIO m) =>
Text -> ImagePullPolicy -> m Bool
podmanPullIfNecessary Text
image ImagePullPolicy
pullPolicy
      imageLoad (toString image) True >> return image

  where
    imageLoad :: (MonadLoggerIO m, HasCallStack) => String -> Bool -> m ()
    imageLoad :: forall (m :: * -> *).
(MonadLoggerIO m, HasCallStack) =>
FilePath -> Bool -> m ()
imageLoad FilePath
toLoad Bool
daemon = do
      let extraFlags :: [FilePath]
extraFlags = case Text
"--rootless" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [Text]
minikubeFlags of
                         Bool
True -> [FilePath
"--rootless"]
                         Bool
False -> []

      let args :: [FilePath]
args = [FilePath
"image", FilePath
"load", FilePath
toLoad
                 , FilePath
"--profile", Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
clusterName
                 , FilePath
"--logtostderr=true", FilePath
"--v=1"
                 , [i|--daemon=#{A.encode daemon}|]
                 ] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
extraFlags

      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|#{minikubeBinary} #{T.unwords $ fmap toText args}|]

      -- Gather stderr output while also logging it
      logFn <- m (Loc -> Text -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLoggerIO m =>
m (Loc -> Text -> LogLevel -> LogStr -> IO ())
askLoggerIO
      stderrOutputVar <- newIORef mempty
      let customLogFn Loc
loc Text
src LogLevel
level LogStr
str = do
            IORef LogStr -> (LogStr -> LogStr) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef LogStr
stderrOutputVar (LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
str)
            Loc -> Text -> LogLevel -> LogStr -> IO ()
logFn Loc
loc Text
src LogLevel
level LogStr
str

      liftIO $ flip runLoggingT customLogFn $
        createProcessWithLogging (proc minikubeBinary args)
          >>= waitForProcess >>= (`shouldBe` ExitSuccess)

      stderrOutput <- fromLogStr <$> readIORef stderrOutputVar

      let ef (Text
details :: Text) = FilePath -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadIO m) =>
FilePath -> m a
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 :: ByteString -> Bool
check1 ByteString
bytes = ByteString
"Failed to load cached images for profile" ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
bytes
                 Bool -> Bool -> Bool
&& ByteString
"make sure the profile is running." ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
bytes

    check2 :: ByteString -> Bool
check2 ByteString
bytes = ByteString
"ctr: failed to ingest" ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
bytes
                 Bool -> Bool -> Bool
&& ByteString
"failed to copy: failed to send write: error reading from server: EOF: unavailable" ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
bytes

    check3 :: ByteString -> Bool
    check3 :: ByteString -> Bool
check3 ByteString
bytes = ByteString
bytes ByteString -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"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 :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
FilePath -> Text -> [Text] -> m (Set Text)
getLoadedImagesMinikube FilePath
minikubeBinary Text
clusterName [Text]
minikubeFlags = do
  -- TODO: use "--format json" and parse?
  ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text)
-> (FilePath -> [Text]) -> FilePath -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words (Text -> [Text]) -> (FilePath -> Text) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. ToText a => a -> Text
toText) (FilePath -> Set Text) -> m FilePath -> m (Set Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateProcess -> FilePath -> m FilePath
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> FilePath -> m FilePath
readCreateProcessWithLogging (
    FilePath -> [FilePath] -> CreateProcess
proc FilePath
minikubeBinary ([FilePath
"image", FilePath
"ls"
                         , FilePath
"--profile", Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
clusterName
                         ] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
forall a. ToString a => a -> FilePath
toString [Text]
minikubeFlags)) FilePath
""

-- | 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 :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
FilePath -> Text -> [Text] -> Text -> m Bool
clusterContainsImageMinikube FilePath
minikubeBinary Text
clusterName [Text]
minikubeFlags Text
image = do
  imageName <- case FilePath -> Bool
isAbsolute (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
image) of
    Bool
False -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
image
    Bool
True -> FilePath -> m Text
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
FilePath -> m Text
readImageName (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
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
    )