content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeOperators #-}
  {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
  
  {-|
  
  [MinIO](https://min.io/) is a popular S3-compatible object storage system. This module provides some tools to introduce it, either as a raw binary or via a container system.
  
  The MinIO server will be introduced as a generic 'TestS3Server'. This gives you the ability to easily swap out different S3-compatible stores in your tests.
  
  -}
  
  module Test.Sandwich.Contexts.MinIO (
    -- * Introducing MinIO
    introduceMinIOViaNix
    , introduceMinIOViaBinary
    , introduceMinIOViaContainer
  
    -- * Lower-level versions
    , withMinIOViaBinary
    , withMinIOViaBinary'
    , withMinIOViaContainer
  
    -- * Helpers for constructing connections
    , testS3ServerEndpoint
    , testS3ServerContainerEndpoint
    , testS3ServerConnectInfo
  
    -- * Re-exports
    , testS3Server
    , TestS3Server(..)
    , HasTestS3Server
    , ContainerOptions(..)
    , defaultContainerOptions
    , HttpMode(..)
    , NetworkAddress(..)
  
    -- * Types
    , MinIOContextOptions (..)
    , defaultMinIOContextOptions
    ) where
  
  import Control.Monad
  import Control.Monad.Catch (MonadMask)
  import qualified Control.Monad.Catch as MC
  import Control.Monad.IO.Unlift
  import Control.Monad.Logger
  import Control.Retry
  import qualified Data.Aeson as A
  import qualified Data.List as L
  import qualified Data.Map as M
  import Data.String.Interpolate
  import qualified Data.Text as T
  import qualified Data.Text.IO as T
  import GHC.TypeLits
  import Network.Minio
  import Network.Socket (PortNumber)
  import Network.URI (URI(..), URIAuth(..), parseURI)
  import Relude
  import Safe
  import System.Exit
  import System.FilePath
  import System.IO.Temp
  import Test.Sandwich
  import Test.Sandwich.Contexts.Container (ContainerOptions(..), containerPortToHostPort, defaultContainerOptions)
  import Test.Sandwich.Contexts.Files
  import Test.Sandwich.Contexts.HttpWaits
  import Test.Sandwich.Contexts.MinIO.Util
  import Test.Sandwich.Contexts.Nix
  import Test.Sandwich.Contexts.Types.Network
  import Test.Sandwich.Contexts.Types.S3
  import UnliftIO.Async
  import UnliftIO.Directory
  import UnliftIO.Exception
  import UnliftIO.Process
  import UnliftIO.Timeout
  
  
  -- * Types
  
  -- | Construct a 'ConnectInfo' (from the @minio-hs@ package) for the given 'TestS3Server'.
  testS3ServerConnectInfo :: TestS3Server -> ConnectInfo
  testS3ServerConnectInfo testServ@(TestS3Server {..}) =
    fromString (toString (testS3ServerEndpoint testServ))
    & setCreds (CredentialValue (AccessKey testS3ServerAccessKeyId) (SecretKey (fromString (toString testS3ServerSecretAccessKey))) Nothing)
    & (if testS3ServerHttpMode == HttpModeHttpsNoValidate then disableTLSCertValidation else id)
  
  data MinIOContextOptions = MinIOContextOptions {
    -- | Bucket name to create on startup.
    minioContextBucket :: Maybe Text
  
    -- | Image name to use when launching MinIO in container mode.
    , minioContextImageName :: String
    -- | Container labels to apply when launching MinIO in container mode.
    , minioContextLabels :: Map Text Text
  
    -- | Maximum time to wait in microseconds before seeing an "API:" message during startup
    , minioContextStartupTimeout :: Int
    } deriving (Show, Eq)
  defaultMinIOContextOptions :: MinIOContextOptions
  defaultMinIOContextOptions = MinIOContextOptions {
    minioContextBucket = Just "bucket1"
  
    , minioContextImageName = "minio/minio:RELEASE.2022-09-25T15-44-53Z"
    , minioContextLabels = mempty
  
    , minioContextStartupTimeout = 60_000_000
    }
  
  -- * Raw
  
  -- | Introduce a MinIO server, deriving the MinIO binary from the Nix context.
  introduceMinIOViaNix :: (
    HasBaseContext context, HasNixContext context, MonadMask m, MonadUnliftIO m
    )
    -- | Options
    => MinIOContextOptions
    -> SpecFree (LabelValue "testS3Server" TestS3Server :> LabelValue (AppendSymbol "file-" "minio") (EnvironmentFile "minio") :> context) m ()
    -> SpecFree context m ()
  introduceMinIOViaNix options = introduceBinaryViaNixPackage @"minio" "minio" .
    introduceWith "MinIO S3 server (via Nix binary)" testS3Server (withMinIOViaBinary options)
  
  -- | Introduce a MinIO server, assuming the binary is already available as a 'HasFile' context.
  introduceMinIOViaBinary :: (
    HasBaseContext context, HasFile context "minio", MonadMask m, MonadUnliftIO m
    )
    -- | Options
    => MinIOContextOptions
    -> SpecFree (LabelValue "testS3Server" TestS3Server :> context) m ()
    -> SpecFree context m ()
  introduceMinIOViaBinary options =
    introduceWith "MinIO S3 server (via Nix binary)" testS3Server (withMinIOViaBinary options)
  
  -- | Bracket-style variant of 'introduceMinIOViaBinary'.
  withMinIOViaBinary :: (
    HasBaseContextMonad context m, HasFile context "minio"
    , MonadLoggerIO m, MonadMask m, MonadUnliftIO m
    )
    -- | Options
    => MinIOContextOptions
    -> (TestS3Server -> m [Result])
    -> m ()
  withMinIOViaBinary options action = do
    minioPath <- askFile @"minio"
    withMinIOViaBinary' minioPath options action
  
  -- | Introduce a MinIO server by manually providing the path to the binary.
  withMinIOViaBinary' :: (
    HasBaseContextMonad context m
    , MonadLoggerIO m, MonadMask m, MonadUnliftIO m
    )
    -- | Path to the @minio@ binary
    => FilePath
    -> MinIOContextOptions
    -> (TestS3Server -> m [Result])
    -> m ()
  withMinIOViaBinary' minioPath (MinIOContextOptions {..}) action = do
    dir <- getCurrentFolder >>= \case
      Nothing -> expectationFailure "withMinIOViaBinary must be run with a current directory."
      Just x -> return x
  
    minioDir <- liftIO $ createTempDirectory dir "minio-storage"
  
    (hRead, hWrite) <- liftIO createPipe
    let cp = proc minioPath [
          "server"
          , minioDir
          , "--address", ":0"
          , "--json"
          ]
  
    withCreateProcess (cp { std_in = CreatePipe, std_out = UseHandle hWrite, std_err = UseHandle hWrite }) $ \_ _ _ _p -> do
      maybeUriToUse <- timeout minioContextStartupTimeout $ fix $ \loop -> do
        line <- liftIO $ T.hGetLine hRead
        debug [i|minio: #{line}|]
        case A.eitherDecode (encodeUtf8 line) of
          Right (A.Object ( aesonLookup "message" -> Just (A.String t) ))
            | "API:" `T.isInfixOf` t -> do
                return $ t
                       & T.words
                       & mapMaybe (parseURI . toString)
                       & L.sortOn scoreUri
                       & headMay
            | otherwise -> loop
          _ -> loop
  
      uriToUse <- case maybeUriToUse of
        Nothing -> expectationFailure [i|Didn't see "API:" message in MinIO output.|]
        Just x -> pure x
  
      let forwardOutput = forever $ do
            line <- liftIO $ T.hGetLine hRead
            debug [i|minio: #{line}|]
  
      withAsync forwardOutput $ \_ -> do
        (hostname, port) <- case uriToUse of
          Nothing -> expectationFailure [i|Couldn't find MinIO URI to use.|]
          Just (URI { uriAuthority=(Just URIAuth {..}) }) -> case readMaybe (L.drop 1 uriPort) of
            Just p -> pure (uriRegName, p)
            Nothing -> expectationFailure [i|Couldn't parse URI port: '#{uriPort}'|]
          Just uri -> expectationFailure [i|MinIO URI didn't have hostname: #{uri}|]
  
        let server = TestS3Server {
              testS3ServerAddress = NetworkAddressTCP hostname port
              , testS3ServerContainerAddress = Nothing
              , testS3ServerAccessKeyId = "minioadmin"
              , testS3ServerSecretAccessKey = "minioadmin"
              , testS3ServerBucket = minioContextBucket
              , testS3ServerHttpMode = HttpModeHttp
              }
  
        info [i|About to do waitForMinIOReady|]
  
        waitForMinIOReady server
  
        void $ action server
  
    where
      -- URIs will be sorted from low to high according to this key function
      scoreUri :: URI -> Int
      scoreUri (URI { uriAuthority=(Just URIAuth {..}) })
        | uriRegName == "127.0.0.1" = -10
        | uriRegName == "localhost" = -5
      scoreUri _ = 0
  
  
  -- * Container
  
  -- | Introduce a MinIO server by launching a container.
  introduceMinIOViaContainer :: (
    HasBaseContext context, MonadMask m, MonadUnliftIO m
    )
    -- | Options
    => MinIOContextOptions
    -> ContainerOptions
    -> SpecFree (LabelValue "testS3Server" TestS3Server :> context) m ()
    -> SpecFree context m ()
  introduceMinIOViaContainer options containerOptions = introduceWith "MinIO S3 server (via container)" testS3Server $ \action -> do
    withMinIOViaContainer options containerOptions action
  
  -- | Bracket-style variant of 'introduceMinIOViaContainer'.
  withMinIOViaContainer :: (
    HasBaseContextMonad context m
    , MonadLoggerIO m, MonadMask m, MonadUnliftIO m
    )
    -- | Options
    => MinIOContextOptions
    -> ContainerOptions
    -> (TestS3Server -> m [Result])
    -> m ()
  withMinIOViaContainer (MinIOContextOptions {..}) (ContainerOptions {..}) action = do
    folder <- getCurrentFolder >>= \case
      Nothing -> expectationFailure "withMinIOViaContainer must be run with a current directory."
      Just x -> return x
  
    let mockDir = folder </> "mock_root"
    createDirectoryIfMissing True mockDir
    liftIO $ void $ readCreateProcess (proc "chmod" ["777", mockDir]) "" -- Fix permission problems on GitHub Runners
  
    let innerPort = 9000 :: PortNumber
  
    uuid <- makeUUID
    let containerName = fromMaybe ("test-s3-" <> uuid) containerOptionsName
  
    let labelArgs = case minioContextLabels of
          x | M.null x -> []
          xs -> "--label" : [[i|#{k}=#{v}|] | (k, v) <- M.toList xs]
  
    bracket (do
                uid <- liftIO getCurrentUID
  
                let cp = proc (show containerOptionsSystem) $ [
                      "run"
                      , "-d"
                      , "-p", [i|#{innerPort}|]
                      , "-v", [i|#{mockDir}:/data|]
                      , "-u", [i|#{uid}|]
                      , "--name", toString containerName
                      ]
                      <> labelArgs
                      <> [
                          minioContextImageName
                          , "server", "/data", "--console-address", ":9001"
                         ]
  
                info [i|Got command: #{cp}"|]
  
                createProcessWithLogging cp
            )
            (\_ -> do
                void $ liftIO $ readCreateProcess (shell [i|#{containerOptionsSystem} rm -f --volumes #{containerName}|]) ""
            )
            (\p -> do
                waitForProcess p >>= \case
                  ExitSuccess -> return ()
                  ExitFailure n -> expectationFailure [i|Failed to start MinIO container (exit code #{n})|]
  
                localPort <- containerPortToHostPort containerOptionsSystem containerName innerPort
  
                let server = TestS3Server {
                      testS3ServerAddress = NetworkAddressTCP "127.0.0.1" localPort
                      , testS3ServerContainerAddress = Nothing
                      , testS3ServerAccessKeyId = "minioadmin"
                      , testS3ServerSecretAccessKey = "minioadmin"
                      , testS3ServerBucket = minioContextBucket
                      , testS3ServerHttpMode = HttpModeHttp
                      }
  
                waitForMinIOReady server
  
                void $ action server
            )
  
  
  waitForMinIOReady :: (MonadLogger m, MonadUnliftIO m, MonadMask m) => TestS3Server -> m ()
  waitForMinIOReady server@(TestS3Server {..}) = do
    let endpoint = testS3ServerEndpoint server
  
    -- The minio image seems not to have a healthcheck?
    -- waitForHealth containerName
    waitUntilStatusCodeWithTimeout (2, 0, 0) (1_000_000 * 60 * 5) NoVerify (toString endpoint <> [i|/minio/health/live|])
  
    whenJust testS3ServerBucket $ \bucket -> do
      -- Make the test bucket, retrying on ServiceErr
      let connInfo :: ConnectInfo = setCreds (CredentialValue "minioadmin" "minioadmin" Nothing) (fromString $ toString endpoint)
      let policy = limitRetriesByCumulativeDelay (1_000_000 * 60 * 5) $ capDelay 1_000_000 $ exponentialBackoff 50_000
      let handlers = [\_ -> MC.Handler (\case (ServiceErr {}) -> return True; _ -> return False)
                     , \_ -> MC.Handler (\case (MErrService (ServiceErr {})) -> return True; _ -> return False)]
      debug [i|Starting to try to make bucket at #{endpoint}|]
      recovering policy handlers $ \retryStatus@(RetryStatus {}) -> do
        info [i|About to try making S3 bucket with retry status: #{retryStatus}|]
        liftIO $ doMakeBucket connInfo bucket
  
    debug [i|MinIO S3 server ready: #{server}|]
  
  
  doMakeBucket :: ConnectInfo -> Bucket -> IO ()
  doMakeBucket connInfo bucket = do
    result <- runMinio connInfo $ do
      try (makeBucket bucket Nothing) >>= \case
        Left BucketAlreadyOwnedByYou -> return ()
        Left e -> throwIO e
        Right _ -> return ()
  
    whenLeft_ result throwIO
  
  getCurrentUID :: (HasCallStack, MonadIO m) => m Int
  getCurrentUID = (readMay <$> (readCreateProcess (proc "id" ["-u"]) "")) >>= \case
    Nothing -> expectationFailure [i|Couldn't parse UID|]
    Just x -> return x
  