{-# 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 :: TestS3Server -> ConnectInfo
testS3ServerConnectInfo testServ :: TestS3Server
testServ@(TestS3Server {Maybe Text
Maybe NetworkAddress
Text
NetworkAddress
HttpMode
testS3ServerAddress :: NetworkAddress
testS3ServerContainerAddress :: Maybe NetworkAddress
testS3ServerAccessKeyId :: Text
testS3ServerSecretAccessKey :: Text
testS3ServerBucket :: Maybe Text
testS3ServerHttpMode :: HttpMode
testS3ServerAccessKeyId :: TestS3Server -> Text
testS3ServerAddress :: TestS3Server -> NetworkAddress
testS3ServerBucket :: TestS3Server -> Maybe Text
testS3ServerContainerAddress :: TestS3Server -> Maybe NetworkAddress
testS3ServerHttpMode :: TestS3Server -> HttpMode
testS3ServerSecretAccessKey :: TestS3Server -> Text
..}) =
  String -> ConnectInfo
forall a. IsString a => String -> a
fromString (Text -> String
forall a. ToString a => a -> String
toString (TestS3Server -> Text
testS3ServerEndpoint TestS3Server
testServ))
  ConnectInfo -> (ConnectInfo -> ConnectInfo) -> ConnectInfo
forall a b. a -> (a -> b) -> b
& CredentialValue -> ConnectInfo -> ConnectInfo
setCreds (AccessKey -> SecretKey -> Maybe SessionToken -> CredentialValue
CredentialValue (Text -> AccessKey
AccessKey Text
testS3ServerAccessKeyId) (ScrubbedBytes -> SecretKey
SecretKey (String -> ScrubbedBytes
forall a. IsString a => String -> a
fromString (Text -> String
forall a. ToString a => a -> String
toString Text
testS3ServerSecretAccessKey))) Maybe SessionToken
forall a. Maybe a
Nothing)
  ConnectInfo -> (ConnectInfo -> ConnectInfo) -> ConnectInfo
forall a b. a -> (a -> b) -> b
& (if HttpMode
testS3ServerHttpMode HttpMode -> HttpMode -> Bool
forall a. Eq a => a -> a -> Bool
== HttpMode
HttpModeHttpsNoValidate then ConnectInfo -> ConnectInfo
disableTLSCertValidation else ConnectInfo -> ConnectInfo
forall a. a -> a
id)

data MinIOContextOptions = MinIOContextOptions {
  MinIOContextOptions -> Maybe Text
minioContextBucket :: Maybe Text
  , MinIOContextOptions -> Map Text Text
minioContextLabels :: Map Text Text
  -- | Maximum time to wait in microseconds before seeing an "API:" message during startup
  , MinIOContextOptions -> Int
minioContextStartupTimeout :: Int
  } deriving (Int -> MinIOContextOptions -> ShowS
[MinIOContextOptions] -> ShowS
MinIOContextOptions -> String
(Int -> MinIOContextOptions -> ShowS)
-> (MinIOContextOptions -> String)
-> ([MinIOContextOptions] -> ShowS)
-> Show MinIOContextOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MinIOContextOptions -> ShowS
showsPrec :: Int -> MinIOContextOptions -> ShowS
$cshow :: MinIOContextOptions -> String
show :: MinIOContextOptions -> String
$cshowList :: [MinIOContextOptions] -> ShowS
showList :: [MinIOContextOptions] -> ShowS
Show, MinIOContextOptions -> MinIOContextOptions -> Bool
(MinIOContextOptions -> MinIOContextOptions -> Bool)
-> (MinIOContextOptions -> MinIOContextOptions -> Bool)
-> Eq MinIOContextOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MinIOContextOptions -> MinIOContextOptions -> Bool
== :: MinIOContextOptions -> MinIOContextOptions -> Bool
$c/= :: MinIOContextOptions -> MinIOContextOptions -> Bool
/= :: MinIOContextOptions -> MinIOContextOptions -> Bool
Eq)
defaultMinIOContextOptions :: MinIOContextOptions
defaultMinIOContextOptions :: MinIOContextOptions
defaultMinIOContextOptions = MinIOContextOptions {
  minioContextBucket :: Maybe Text
minioContextBucket = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"bucket1"
  , minioContextLabels :: Map Text Text
minioContextLabels = Map Text Text
forall a. Monoid a => a
mempty
  , minioContextStartupTimeout :: Int
minioContextStartupTimeout = Int
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 :: forall context (m :: * -> *).
(HasBaseContext context, HasNixContext context, MonadMask m,
 MonadUnliftIO m) =>
MinIOContextOptions
-> SpecFree
     (LabelValue "testS3Server" TestS3Server
      :> (LabelValue
            (AppendSymbol "file-" "minio") (EnvironmentFile "minio")
          :> context))
     m
     ()
-> SpecFree context m ()
introduceMinIOViaNix MinIOContextOptions
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 @"minio" Text
"minio" (Free
   (SpecCommand
      (LabelValue "file-minio" (EnvironmentFile "minio") :> context) m)
   ()
 -> SpecFree context m ())
-> (SpecFree
      (LabelValue "testS3Server" TestS3Server
       :> (LabelValue "file-minio" (EnvironmentFile "minio") :> context))
      m
      ()
    -> Free
         (SpecCommand
            (LabelValue "file-minio" (EnvironmentFile "minio") :> context) m)
         ())
-> SpecFree
     (LabelValue "testS3Server" TestS3Server
      :> (LabelValue "file-minio" (EnvironmentFile "minio") :> context))
     m
     ()
-> SpecFree context m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String
-> Label "testS3Server" TestS3Server
-> ((HasCallStack =>
     TestS3Server
     -> ExampleT
          (LabelValue "file-minio" (EnvironmentFile "minio") :> context)
          m
          [Result])
    -> ExampleT
         (LabelValue "file-minio" (EnvironmentFile "minio") :> context)
         m
         ())
-> SpecFree
     (LabelValue "testS3Server" TestS3Server
      :> (LabelValue "file-minio" (EnvironmentFile "minio") :> context))
     m
     ()
-> Free
     (SpecCommand
        (LabelValue "file-minio" (EnvironmentFile "minio") :> 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
"MinIO S3 server (via Nix binary)" Label "testS3Server" TestS3Server
testS3Server (MinIOContextOptions
-> (TestS3Server
    -> ExampleT
         (LabelValue "file-minio" (EnvironmentFile "minio") :> context)
         m
         [Result])
-> ExampleT
     (LabelValue "file-minio" (EnvironmentFile "minio") :> context) m ()
forall context (m :: * -> *).
(HasBaseContextMonad context m, HasFile context "minio",
 MonadLoggerIO m, MonadMask m, MonadUnliftIO m) =>
MinIOContextOptions -> (TestS3Server -> m [Result]) -> m ()
withMinIOViaBinary MinIOContextOptions
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 :: forall context (m :: * -> *).
(HasBaseContext context, HasFile context "minio", MonadMask m,
 MonadUnliftIO m) =>
MinIOContextOptions
-> SpecFree
     (LabelValue "testS3Server" TestS3Server :> context) m ()
-> SpecFree context m ()
introduceMinIOViaBinary MinIOContextOptions
options =
  String
-> Label "testS3Server" TestS3Server
-> ((HasCallStack => TestS3Server -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree
     (LabelValue "testS3Server" TestS3Server :> context) m ()
-> SpecFree 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
"MinIO S3 server (via Nix binary)" Label "testS3Server" TestS3Server
testS3Server (MinIOContextOptions
-> (TestS3Server -> ExampleT context m [Result])
-> ExampleT context m ()
forall context (m :: * -> *).
(HasBaseContextMonad context m, HasFile context "minio",
 MonadLoggerIO m, MonadMask m, MonadUnliftIO m) =>
MinIOContextOptions -> (TestS3Server -> m [Result]) -> m ()
withMinIOViaBinary MinIOContextOptions
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 :: forall context (m :: * -> *).
(HasBaseContextMonad context m, HasFile context "minio",
 MonadLoggerIO m, MonadMask m, MonadUnliftIO m) =>
MinIOContextOptions -> (TestS3Server -> m [Result]) -> m ()
withMinIOViaBinary MinIOContextOptions
options TestS3Server -> m [Result]
action = do
  minioPath <- forall (a :: Symbol) context (m :: * -> *).
(MonadReader context m, HasFile context a) =>
m String
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' :: forall context (m :: * -> *).
(HasBaseContextMonad context m, MonadLoggerIO m, MonadMask m,
 MonadUnliftIO m) =>
String
-> MinIOContextOptions -> (TestS3Server -> m [Result]) -> m ()
withMinIOViaBinary' String
minioPath (MinIOContextOptions {Int
Maybe Text
Map Text Text
minioContextBucket :: MinIOContextOptions -> Maybe Text
minioContextLabels :: MinIOContextOptions -> Map Text Text
minioContextStartupTimeout :: MinIOContextOptions -> Int
minioContextBucket :: Maybe Text
minioContextLabels :: Map Text Text
minioContextStartupTimeout :: Int
..}) TestS3Server -> m [Result]
action = do
  dir <- m (Maybe String)
forall context (m :: * -> *).
HasBaseContextMonad context m =>
m (Maybe String)
getCurrentFolder m (Maybe String) -> (Maybe String -> m String) -> m String
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> String -> m String
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure String
"withMinIOViaBinary must be run with a current directory."
    Just String
x -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x

  minioDir <- liftIO $ createTempDirectory dir "minio-storage"

  (hRead, hWrite) <- liftIO createPipe
  let cp = String -> [String] -> CreateProcess
proc String
minioPath [
        String
"server"
        , String
minioDir
        , String
"--address", String
":0"
        , String
"--json"
        ]

  withCreateProcess (cp { std_in = CreatePipe, std_out = UseHandle hWrite, std_err = UseHandle hWrite }) $ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
_p -> do
    maybeUriToUse <- Int -> m (Maybe URI) -> m (Maybe (Maybe URI))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
minioContextStartupTimeout (m (Maybe URI) -> m (Maybe (Maybe URI)))
-> m (Maybe URI) -> m (Maybe (Maybe URI))
forall a b. (a -> b) -> a -> b
$ (m (Maybe URI) -> m (Maybe URI)) -> m (Maybe URI)
forall a. (a -> a) -> a
fix ((m (Maybe URI) -> m (Maybe URI)) -> m (Maybe URI))
-> (m (Maybe URI) -> m (Maybe URI)) -> m (Maybe URI)
forall a b. (a -> b) -> a -> b
$ \m (Maybe URI)
loop -> do
      line <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ Handle -> IO Text
T.hGetLine Handle
hRead
      debug [i|minio: #{line}|]
      case A.eitherDecode (encodeUtf8 line) of
        Right (A.Object ( Text -> Object -> Maybe Value
forall v. Text -> KeyMap v -> Maybe v
aesonLookup Text
"message" -> Just (A.String Text
t) ))
          | Text
"API:" Text -> Text -> Bool
`T.isInfixOf` Text
t -> do
              Maybe URI -> m (Maybe URI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URI -> m (Maybe URI)) -> Maybe URI -> m (Maybe URI)
forall a b. (a -> b) -> a -> b
$ Text
t
                     Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Text -> [Text]
T.words
                     [Text] -> ([Text] -> [URI]) -> [URI]
forall a b. a -> (a -> b) -> b
& (Text -> Maybe URI) -> [Text] -> [URI]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe URI
parseURI (String -> Maybe URI) -> (Text -> String) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString)
                     [URI] -> ([URI] -> [URI]) -> [URI]
forall a b. a -> (a -> b) -> b
& (URI -> Int) -> [URI] -> [URI]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn URI -> Int
scoreUri
                     [URI] -> ([URI] -> Maybe URI) -> Maybe URI
forall a b. a -> (a -> b) -> b
& [URI] -> Maybe URI
forall a. [a] -> Maybe a
headMay
          | Bool
otherwise -> m (Maybe URI)
loop
        Either String Value
_ -> m (Maybe URI)
loop

    uriToUse <- case maybeUriToUse of
      Maybe (Maybe URI)
Nothing -> String -> m (Maybe URI)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Didn't see "API:" message in MinIO output.|]
      Just Maybe URI
x -> Maybe URI -> m (Maybe URI)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe URI
x

    let forwardOutput = m () -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m b) -> m () -> m b
forall a b. (a -> b) -> a -> b
$ do
          line <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ Handle -> IO Text
T.hGetLine Handle
hRead
          debug [i|minio: #{line}|]

    withAsync forwardOutput $ \Async (ZonkAny 0)
_ -> do
      (hostname, port) <- case Maybe URI
uriToUse of
        Maybe URI
Nothing -> String -> m (String, PortNumber)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't find MinIO URI to use.|]
        Just (URI { uriAuthority :: URI -> Maybe URIAuth
uriAuthority=(Just URIAuth {String
uriUserInfo :: String
uriRegName :: String
uriPort :: String
uriPort :: URIAuth -> String
uriRegName :: URIAuth -> String
uriUserInfo :: URIAuth -> String
..}) }) -> case String -> Maybe PortNumber
forall a. Read a => String -> Maybe a
readMaybe (Int -> ShowS
forall a. Int -> [a] -> [a]
L.drop Int
1 String
uriPort) of
          Just PortNumber
p -> (String, PortNumber) -> m (String, PortNumber)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
uriRegName, PortNumber
p)
          Maybe PortNumber
Nothing -> String -> m (String, PortNumber)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't parse URI port: '#{uriPort}'|]
        Just URI
uri -> String -> m (String, PortNumber)
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|MinIO URI didn't have hostname: #{uri}|]

      let server = TestS3Server {
            testS3ServerAddress :: NetworkAddress
testS3ServerAddress = String -> PortNumber -> NetworkAddress
NetworkAddressTCP String
hostname PortNumber
port
            , testS3ServerContainerAddress :: Maybe NetworkAddress
testS3ServerContainerAddress = Maybe NetworkAddress
forall a. Maybe a
Nothing
            , testS3ServerAccessKeyId :: Text
testS3ServerAccessKeyId = Text
"minioadmin"
            , testS3ServerSecretAccessKey :: Text
testS3ServerSecretAccessKey = Text
"minioadmin"
            , testS3ServerBucket :: Maybe Text
testS3ServerBucket = Maybe Text
minioContextBucket
            , testS3ServerHttpMode :: HttpMode
testS3ServerHttpMode = HttpMode
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 -> Int
scoreUri (URI { uriAuthority :: URI -> Maybe URIAuth
uriAuthority=(Just URIAuth {String
uriPort :: URIAuth -> String
uriRegName :: URIAuth -> String
uriUserInfo :: URIAuth -> String
uriUserInfo :: String
uriRegName :: String
uriPort :: String
..}) })
      | String
uriRegName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"127.0.0.1" = -Int
10
      | String
uriRegName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"localhost" = -Int
5
    scoreUri URI
_ = Int
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 :: forall context (m :: * -> *).
(HasBaseContext context, MonadMask m, MonadUnliftIO m) =>
MinIOContextOptions
-> ContainerOptions
-> SpecFree
     (LabelValue "testS3Server" TestS3Server :> context) m ()
-> SpecFree context m ()
introduceMinIOViaContainer MinIOContextOptions
options ContainerOptions
containerOptions = String
-> Label "testS3Server" TestS3Server
-> ((HasCallStack => TestS3Server -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree
     (LabelValue "testS3Server" TestS3Server :> context) m ()
-> SpecFree 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
"MinIO S3 server (via container)" Label "testS3Server" TestS3Server
testS3Server (((HasCallStack => TestS3Server -> ExampleT context m [Result])
  -> ExampleT context m ())
 -> SpecFree
      (LabelValue "testS3Server" TestS3Server :> context) m ()
 -> SpecFree context m ())
-> ((HasCallStack => TestS3Server -> ExampleT context m [Result])
    -> ExampleT context m ())
-> SpecFree
     (LabelValue "testS3Server" TestS3Server :> context) m ()
-> SpecFree context m ()
forall a b. (a -> b) -> a -> b
$ \HasCallStack => TestS3Server -> ExampleT context m [Result]
action -> do
  MinIOContextOptions
-> ContainerOptions
-> (TestS3Server -> ExampleT context m [Result])
-> ExampleT context m ()
forall context (m :: * -> *).
(HasBaseContextMonad context m, MonadLoggerIO m, MonadMask m,
 MonadUnliftIO m) =>
MinIOContextOptions
-> ContainerOptions -> (TestS3Server -> m [Result]) -> m ()
withMinIOViaContainer MinIOContextOptions
options ContainerOptions
containerOptions HasCallStack => TestS3Server -> ExampleT context m [Result]
TestS3Server -> ExampleT context m [Result]
action

-- | Bracket-style variant of 'introduceMinIOViaContainer'.
withMinIOViaContainer :: (
  HasBaseContextMonad context m
  , MonadLoggerIO m, MonadMask m, MonadUnliftIO m
  )
  -- | Options
  => MinIOContextOptions
  -> ContainerOptions
  -> (TestS3Server -> m [Result])
  -> m ()
withMinIOViaContainer :: forall context (m :: * -> *).
(HasBaseContextMonad context m, MonadLoggerIO m, MonadMask m,
 MonadUnliftIO m) =>
MinIOContextOptions
-> ContainerOptions -> (TestS3Server -> m [Result]) -> m ()
withMinIOViaContainer (MinIOContextOptions {Int
Maybe Text
Map Text Text
minioContextBucket :: MinIOContextOptions -> Maybe Text
minioContextLabels :: MinIOContextOptions -> Map Text Text
minioContextStartupTimeout :: MinIOContextOptions -> Int
minioContextBucket :: Maybe Text
minioContextLabels :: Map Text Text
minioContextStartupTimeout :: Int
..}) (ContainerOptions {Maybe Text
ContainerSystem
containerOptionsSystem :: ContainerSystem
containerOptionsName :: Maybe Text
containerOptionsName :: ContainerOptions -> Maybe Text
containerOptionsSystem :: ContainerOptions -> ContainerSystem
..}) TestS3Server -> m [Result]
action = do
  folder <- m (Maybe String)
forall context (m :: * -> *).
HasBaseContextMonad context m =>
m (Maybe String)
getCurrentFolder m (Maybe String) -> (Maybe String -> m String) -> m String
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> String -> m String
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure String
"withMinIOViaContainer must be run with a current directory."
    Just String
x -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x

  let mockDir = String
folder String -> ShowS
</> String
"mock_root"
  createDirectoryIfMissing True mockDir
  liftIO $ void $ readCreateProcess (proc "chmod" ["777", mockDir]) "" -- Fix permission problems on GitHub Runners

  let innerPort = PortNumber
9000 :: PortNumber

  uuid <- makeUUID
  let containerName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text
"test-s3-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uuid) Maybe Text
containerOptionsName

  let labelArgs = case Map Text Text
minioContextLabels of
        Map Text Text
x | Map Text Text -> Bool
forall k a. Map k a -> Bool
M.null Map Text Text
x -> []
        Map Text Text
xs -> String
"--label" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[i|#{k}=#{v}|] | (Text
k, Text
v) <- Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Text
xs]

  bracket (do
              uid <- liftIO getCurrentUID

              let cp = String -> [String] -> CreateProcess
proc (ContainerSystem -> String
forall b a. (Show a, IsString b) => a -> b
show ContainerSystem
containerOptionsSystem) ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ [
                    String
"run"
                    , String
"-d"
                    , String
"-p", [i|#{innerPort}|]
                    , String
"-v", [i|#{mockDir}:/data|]
                    , String
"-u", [i|#{uid}|]
                    , String
"--name", Text -> String
forall a. ToString a => a -> String
toString Text
containerName
                    ]
                    [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
labelArgs
                    [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [
                        String
"minio/minio:RELEASE.2022-09-25T15-44-53Z"
                        , String
"server", String
"/data", String
"--console-address", String
":9001"
                    ]

              info [i|Got command: #{cp}"|]

              createProcessWithLogging cp
          )
          (\ProcessHandle
_ -> do
              m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> m String -> m ()
forall a b. (a -> b) -> a -> b
$ IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO String
forall (m :: * -> *).
MonadIO m =>
CreateProcess -> String -> m String
readCreateProcess (String -> CreateProcess
shell [i|#{containerOptionsSystem} rm -f --volumes #{containerName}|]) String
""
          )
          (\ProcessHandle
p -> do
              ProcessHandle -> m ExitCode
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ExitCode
waitForProcess ProcessHandle
p 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
>>= \case
                ExitCode
ExitSuccess -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                ExitFailure Int
n -> String -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Failed to start MinIO container (exit code #{n})|]

              localPort <- ContainerSystem -> Text -> PortNumber -> m PortNumber
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
ContainerSystem -> Text -> PortNumber -> m PortNumber
containerPortToHostPort ContainerSystem
containerOptionsSystem Text
containerName PortNumber
innerPort

              let server = TestS3Server {
                    testS3ServerAddress :: NetworkAddress
testS3ServerAddress = String -> PortNumber -> NetworkAddress
NetworkAddressTCP String
"127.0.0.1" PortNumber
localPort
                    , testS3ServerContainerAddress :: Maybe NetworkAddress
testS3ServerContainerAddress = Maybe NetworkAddress
forall a. Maybe a
Nothing
                    , testS3ServerAccessKeyId :: Text
testS3ServerAccessKeyId = Text
"minioadmin"
                    , testS3ServerSecretAccessKey :: Text
testS3ServerSecretAccessKey = Text
"minioadmin"
                    , testS3ServerBucket :: Maybe Text
testS3ServerBucket = Maybe Text
minioContextBucket
                    , testS3ServerHttpMode :: HttpMode
testS3ServerHttpMode = HttpMode
HttpModeHttp
                    }

              waitForMinIOReady server

              void $ action server
          )


waitForMinIOReady :: (MonadLogger m, MonadUnliftIO m, MonadMask m) => TestS3Server -> m ()
waitForMinIOReady :: forall (m :: * -> *).
(MonadLogger m, MonadUnliftIO m, MonadMask m) =>
TestS3Server -> m ()
waitForMinIOReady server :: TestS3Server
server@(TestS3Server {Maybe Text
Maybe NetworkAddress
Text
NetworkAddress
HttpMode
testS3ServerAccessKeyId :: TestS3Server -> Text
testS3ServerAddress :: TestS3Server -> NetworkAddress
testS3ServerBucket :: TestS3Server -> Maybe Text
testS3ServerContainerAddress :: TestS3Server -> Maybe NetworkAddress
testS3ServerHttpMode :: TestS3Server -> HttpMode
testS3ServerSecretAccessKey :: TestS3Server -> Text
testS3ServerAddress :: NetworkAddress
testS3ServerContainerAddress :: Maybe NetworkAddress
testS3ServerAccessKeyId :: Text
testS3ServerSecretAccessKey :: Text
testS3ServerBucket :: Maybe Text
testS3ServerHttpMode :: HttpMode
..}) = do
  let endpoint :: Text
endpoint = TestS3Server -> Text
testS3ServerEndpoint TestS3Server
server

  -- The minio image seems not to have a healthcheck?
  -- waitForHealth containerName
  (Int, Int, Int) -> Int -> VerifyCerts -> String -> m ()
forall (m :: * -> *).
WaitConstraints m =>
(Int, Int, Int) -> Int -> VerifyCerts -> String -> m ()
waitUntilStatusCodeWithTimeout (Int
2, Int
0, Int
0) (Int
1_000_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
5) VerifyCerts
NoVerify (Text -> String
forall a. ToString a => a -> String
toString Text
endpoint String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [i|/minio/health/live|])

  Maybe Text -> (Text -> m ()) -> m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe Text
testS3ServerBucket ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
bucket -> do
    -- Make the test bucket, retrying on ServiceErr
    let ConnectInfo
connInfo :: ConnectInfo = CredentialValue -> ConnectInfo -> ConnectInfo
setCreds (AccessKey -> SecretKey -> Maybe SessionToken -> CredentialValue
CredentialValue AccessKey
"minioadmin" SecretKey
"minioadmin" Maybe SessionToken
forall a. Maybe a
Nothing) (String -> ConnectInfo
forall a. IsString a => String -> a
fromString (String -> ConnectInfo) -> String -> ConnectInfo
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
endpoint)
    let policy :: RetryPolicyM m
policy = Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay (Int
1_000_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
5) (RetryPolicyM m -> RetryPolicyM m)
-> RetryPolicyM m -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay Int
1_000_000 (RetryPolicyM m -> RetryPolicyM m)
-> RetryPolicyM m -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
50_000
    let handlers :: [t -> Handler m Bool]
handlers = [\t
_ -> (ServiceErr -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
MC.Handler (\case (ServiceErr {}) -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True; ServiceErr
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
                   , \t
_ -> (MinioErr -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
MC.Handler (\case (MErrService (ServiceErr {})) -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True; MinioErr
_ -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)]
    Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Starting to try to make bucket at #{endpoint}|]
    RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering RetryPolicyM m
policy [RetryStatus -> Handler m Bool]
forall {t}. [t -> Handler m Bool]
handlers ((RetryStatus -> m ()) -> m ()) -> (RetryStatus -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \retryStatus :: RetryStatus
retryStatus@(RetryStatus {}) -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info [i|About to try making S3 bucket with retry status: #{retryStatus}|]
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> Text -> IO ()
doMakeBucket ConnectInfo
connInfo Text
bucket

  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|MinIO S3 server ready: #{server}|]


doMakeBucket :: ConnectInfo -> Bucket -> IO ()
doMakeBucket :: ConnectInfo -> Text -> IO ()
doMakeBucket ConnectInfo
connInfo Text
bucket = do
  result <- ConnectInfo -> Minio () -> IO (Either MinioErr ())
forall a. ConnectInfo -> Minio a -> IO (Either MinioErr a)
runMinio ConnectInfo
connInfo (Minio () -> IO (Either MinioErr ()))
-> Minio () -> IO (Either MinioErr ())
forall a b. (a -> b) -> a -> b
$ do
    Minio () -> Minio (Either ServiceErr ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (Text -> Maybe Text -> Minio ()
makeBucket Text
bucket Maybe Text
forall a. Maybe a
Nothing) Minio (Either ServiceErr ())
-> (Either ServiceErr () -> Minio ()) -> Minio ()
forall a b. Minio a -> (a -> Minio b) -> Minio b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left ServiceErr
BucketAlreadyOwnedByYou -> () -> Minio ()
forall a. a -> Minio a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Left ServiceErr
e -> ServiceErr -> Minio ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ServiceErr
e
      Right ()
_ -> () -> Minio ()
forall a. a -> Minio a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  whenLeft_ result throwIO

getCurrentUID :: (HasCallStack, MonadIO m) => m Int
getCurrentUID :: forall (m :: * -> *). (HasCallStack, MonadIO m) => m Int
getCurrentUID = (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMay (String -> Maybe Int) -> m String -> m (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CreateProcess -> String -> m String
forall (m :: * -> *).
MonadIO m =>
CreateProcess -> String -> m String
readCreateProcess (String -> [String] -> CreateProcess
proc String
"id" [String
"-u"]) String
"")) m (Maybe Int) -> (Maybe Int -> m Int) -> m Int
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe Int
Nothing -> String -> m Int
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't parse UID|]
  Just Int
x -> Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
x