packages feed

sandwich-contexts-minio (empty) → 0.1.0.0

raw patch · 3 files changed

+440/−0 lines, 3 filesdep +aesondep +basedep +containers

Dependencies added: aeson, base, containers, exceptions, filepath, minio-hs, monad-logger, network, network-uri, random, relude, retry, safe, sandwich, sandwich-contexts, string-interpolate, temporary, text, unliftio, unliftio-core

Files

+ lib/Test/Sandwich/Contexts/MinIO.hs view
@@ -0,0 +1,339 @@+{-# 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
+ lib/Test/Sandwich/Contexts/MinIO/Util.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+++module Test.Sandwich.Contexts.MinIO.Util where++import Data.Char+import qualified Data.List as L+import Data.Text as T+import Relude+import qualified System.Random as R++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key             as A+import qualified Data.Aeson.KeyMap          as HM+#else+import Data.Hashable+import qualified Data.HashMap.Strict        as HM+#endif+++#if MIN_VERSION_aeson(2,0,0)+aesonLookup :: Text -> HM.KeyMap v -> Maybe v+aesonLookup = HM.lookup . A.fromText+#else+aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v+aesonLookup = HM.lookup+#endif++makeUUID :: MonadIO m => m T.Text+makeUUID = makeUUID' 8++makeUUID' :: MonadIO m => Int -> m T.Text+makeUUID' n = toText <$> (replicateM n ((uuidLetters L.!!) <$> R.randomRIO (0, numUUIDLetters - 1)))+  where+    -- Note: for a UUID to appear in a Kubernetes name, it needs to match this regex+    -- [a-z0-9]([-a-z0-9]*[a-z0-9])?(\.[a-z0-9]([-a-z0-9]*[a-z0-9])?)*'+    uuidLetters :: [Char]+    uuidLetters = ['a'..'z'] ++ ['0'..'9']++    numUUIDLetters :: Int+    numUUIDLetters = L.length uuidLetters
+ sandwich-contexts-minio.cabal view
@@ -0,0 +1,60 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           sandwich-contexts-minio+version:        0.1.0.0+synopsis:       Sandwich test contexts for MinIO+description:    Please see README.md+author:         Tom McLaughlin+maintainer:     tom@codedown.io+copyright:      2024 Tom McLaughlin+license:        BSD3+build-type:     Simple++library+  exposed-modules:+      Test.Sandwich.Contexts.MinIO+  other-modules:+      Test.Sandwich.Contexts.MinIO.Util+      Paths_sandwich_contexts_minio+  hs-source-dirs:+      lib+  default-extensions:+      OverloadedStrings+      QuasiQuotes+      NamedFieldPuns+      RecordWildCards+      ScopedTypeVariables+      LambdaCase+      MultiWayIf+      ViewPatterns+      TupleSections+      FlexibleContexts+      NoImplicitPrelude+      NumericUnderscores+  ghc-options: -Wunused-packages -Wall+  build-depends:+      aeson+    , base >=4.11 && <5+    , containers+    , exceptions+    , filepath+    , minio-hs+    , monad-logger+    , network+    , network-uri+    , random+    , relude+    , retry+    , safe+    , sandwich >=0.3.0.3+    , sandwich-contexts+    , string-interpolate+    , temporary+    , text+    , unliftio+    , unliftio-core+  default-language: Haskell2010