{-# 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
  , 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)
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

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 {
  minioContextBucket :: Maybe Text
  , 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"
  , 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
                    <> [
                        "minio/minio:RELEASE.2022-09-25T15-44-53Z"
                        , "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