diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for testcontainer-hs +## 0.5.3.0 -- 2026-03-31 + +* Removed dependency on `optics-core` and `aeson-optics` (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/70) + ## 0.5.2.0 -- 2025-08-28 * Introduce `withCopyFileToContainer` to copy local files to the container (@LaurentRDC, https://github.com/testcontainers/testcontainers-hs/pull/62) diff --git a/src/TestContainers/Docker.hs b/src/TestContainers/Docker.hs --- a/src/TestContainers/Docker.hs +++ b/src/TestContainers/Docker.hs @@ -180,11 +180,11 @@ runResourceT, ) import Data.Aeson (decode') -import qualified Data.Aeson.Optics as Optics import qualified Data.ByteString.Lazy.Char8 as LazyByteString import Data.Function ((&)) +import Data.Functor ((<&>)) import Data.List (find, stripPrefix) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import Data.String (IsString (..)) import Data.Text (Text, pack, splitOn, strip, unpack) import Data.Text.Encoding (encodeUtf8) @@ -205,9 +205,6 @@ ) import Network.HTTP.Types (statusCode) import qualified Network.Socket as Socket -import Optics.Fold (pre) -import Optics.Operators ((^?)) -import Optics.Optic ((%), (<&>)) import System.Directory (doesFileExist) import System.Environment (lookupEnv) import System.IO (Handle, hClose) @@ -233,6 +230,7 @@ dockerWithStdin, prefixedLogConsumer, ) +import TestContainers.Docker.JSON (asText, eachMember, eachValue, lookupKey) import TestContainers.Docker.Network ( Network, NetworkId, @@ -923,7 +921,7 @@ internalInspect configTracer id let state = containerState inspectOutput - containerName = inspectOutput ^? Optics.key "Name" % Optics._String + containerName = lookupKey "Name" inspectOutput >>= asText exception = InvalidStateException { id = id, @@ -1123,7 +1121,7 @@ case result of Nothing -> do let Container {image, inspectOutput} = container - containerName = inspectOutput ^? Optics.key "Name" % Optics._String + containerName = lookupKey "Name" inspectOutput >>= asText throwM $ TimeoutException { id, @@ -1200,12 +1198,9 @@ -- | Get the IP address of a running Docker container using @docker inspect@. internalContainerIp :: Container -> Text internalContainerIp Container {id, inspectOutput, image} = - case inspectOutput - ^? Optics.key "NetworkSettings" - % Optics.key "IPAddress" - % Optics._String of + case lookupKey "NetworkSettings" inspectOutput >>= lookupKey "IPAddress" >>= asText of Nothing -> do - let containerName = inspectOutput ^? Optics.key "Name" % Optics._String + let containerName = lookupKey "Name" inspectOutput >>= asText throw $ InspectOutputUnexpected { id, @@ -1221,25 +1216,21 @@ -- @since 0.5.0.0 containerAlias :: Container -> Text containerAlias Container {id, inspectOutput, image} = - case inspectOutput - ^? pre - ( Optics.key "NetworkSettings" - % Optics.key "Networks" - % Optics.members - % Optics.key "Aliases" - % Optics.values - % Optics._String - ) of - Nothing -> do - let containerName = inspectOutput ^? Optics.key "Name" % Optics._String - throw $ - InspectOutputMissingNetwork - { id, - imageName = Just (imageTag image), - containerName = containerName - } - Just alias -> - alias + let aliases = do + network <- maybe [] eachMember (lookupKey "NetworkSettings" inspectOutput >>= lookupKey "Networks") + aliasValue <- maybe [] eachValue (lookupKey "Aliases" network) + maybe [] pure (asText aliasValue) + in case listToMaybe aliases of + Nothing -> do + let containerName = lookupKey "Name" inspectOutput >>= asText + throw $ + InspectOutputMissingNetwork + { id, + imageName = Just (imageTag image), + containerName = containerName + } + Just alias -> + alias -- | Get the IP address for the container's gateway, i.e. the host. -- Takes the first gateway address found. @@ -1247,24 +1238,20 @@ -- @since 0.5.0.0 containerGateway :: Container -> Text containerGateway Container {id, inspectOutput, image} = - case inspectOutput - ^? pre - ( Optics.key "NetworkSettings" - % Optics.key "Networks" - % Optics.members - % Optics.key "Gateway" - % Optics._String - ) of - Nothing -> do - let containerName = inspectOutput ^? Optics.key "Name" % Optics._String - throw $ - InspectOutputMissingNetwork - { id, - imageName = Just (imageTag image), - containerName = containerName - } - Just gatewayIp -> - gatewayIp + let gateways = do + network <- maybe [] eachMember (lookupKey "NetworkSettings" inspectOutput >>= lookupKey "Networks") + maybe [] pure (lookupKey "Gateway" network >>= asText) + in case listToMaybe gateways of + Nothing -> do + let containerName = lookupKey "Name" inspectOutput >>= asText + throw $ + InspectOutputMissingNetwork + { id, + imageName = Just (imageTag image), + containerName = containerName + } + Just gatewayIp -> + gatewayIp -- | Looks up an exposed port on the host. -- @@ -1278,26 +1265,28 @@ in -- TODO be more mindful, make sure to grab the -- port from the right host address - case inspectOutput - ^? pre - ( Optics.key "NetworkSettings" - % Optics.key "Ports" - % Optics.key textPort - % Optics.values - % Optics.key "HostPort" - % Optics._String - ) of - Nothing -> - let containerName = inspectOutput ^? Optics.key "Name" % Optics._String - in throw $ - UnknownPortMapping - { id, - port = textPort, - imageName = Just (imageTag image), - containerName = containerName - } - Just hostPort -> - read (unpack hostPort) + let hostPorts = do + entry <- + maybe + [] + eachValue + ( lookupKey "NetworkSettings" inspectOutput + >>= lookupKey "Ports" + >>= lookupKey (show port <> "/" <> unpack protocol) + ) + maybe [] pure (lookupKey "HostPort" entry >>= asText) + in case listToMaybe hostPorts of + Nothing -> + let containerName = lookupKey "Name" inspectOutput >>= asText + in throw $ + UnknownPortMapping + { id, + port = textPort, + imageName = Just (imageTag image), + containerName = containerName + } + Just hostPort -> + read (unpack hostPort) -- | Returns the domain and port exposing the given container's port. Differs -- from 'containerPort' in that 'containerAddress' will return the container's diff --git a/src/TestContainers/Docker/JSON.hs b/src/TestContainers/Docker/JSON.hs new file mode 100644 --- /dev/null +++ b/src/TestContainers/Docker/JSON.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Helpers for navigating aeson 'Value' trees without +-- an optics dependency. +module TestContainers.Docker.JSON + ( lookupKey, + asText, + asBool, + asInteger, + eachMember, + eachValue, + ) +where + +import Data.Aeson (Value (..), withObject) +import Data.Aeson.Types (parseMaybe, (.:)) +import Data.Scientific (floatingOrInteger) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Vector as Vector + +-- | Look up a key in a JSON object. Works across aeson 1.x and 2.x +-- because '(.:)' accepts both 'Text' and 'Key' via 'IsString'. +lookupKey :: String -> Value -> Maybe Value +lookupKey k = parseMaybe (withObject "object" (\obj -> obj .: fromString k)) + +-- | Extract a 'Text' from a JSON 'String' value. +asText :: Value -> Maybe Text +asText (String t) = Just t +asText _ = Nothing + +-- | Extract a 'Bool' from a JSON boolean value. +asBool :: Value -> Maybe Bool +asBool (Bool b) = Just b +asBool _ = Nothing + +-- | Extract an 'Integer' from a JSON number value. +asInteger :: Value -> Maybe Integer +asInteger (Number n) = + case floatingOrInteger n of + Right i -> Just i + Left _floatingPoint -> Nothing +asInteger _ = Nothing + +-- | Collect all member values from a JSON object. +eachMember :: Value -> [Value] +eachMember (Object obj) = foldMap (: []) obj +eachMember _ = [] + +-- | Collect all elements from a JSON array. +eachValue :: Value -> [Value] +eachValue (Array arr) = Vector.toList arr +eachValue _ = [] diff --git a/src/TestContainers/Docker/State.hs b/src/TestContainers/Docker/State.hs --- a/src/TestContainers/Docker/State.hs +++ b/src/TestContainers/Docker/State.hs @@ -19,11 +19,9 @@ import Control.Exception (Exception, throw) import Data.Aeson (Value) -import qualified Data.Aeson.Optics as Optics import Data.Text (Text) -import Optics.Operators ((^?)) -import Optics.Optic ((%)) import TestContainers.Docker.Internal (InspectOutput) +import TestContainers.Docker.JSON (asBool, asInteger, asText, lookupKey) -- | An exception thrown in case the State object is invalid and couldn't be parsed. -- @@ -57,7 +55,7 @@ -- @since 0.5.0.0 containerState :: InspectOutput -> State containerState inspectOutput = - case inspectOutput ^? Optics.key "State" of + case lookupKey "State" inspectOutput of Just state -> State state Nothing -> State "dummy" @@ -66,9 +64,7 @@ -- @since 0.5.0.0 stateStatus :: State -> Status stateStatus (State value) = - case value - ^? Optics.key "Status" - % Optics._String of + case lookupKey "Status" value >>= asText of Just "created" -> Created Just "running" -> Running Just "paused" -> Paused @@ -84,9 +80,7 @@ -- @since 0.5.0.0 stateOOMKilled :: State -> Bool stateOOMKilled (State value) = - case value - ^? Optics.key "OOMKilled" - % Optics._Bool of + case lookupKey "OOMKilled" value >>= asBool of Just True -> True _ -> False @@ -95,9 +89,7 @@ -- @since 0.5.0.0 statePid :: State -> Maybe Int statePid (State value) = - case value - ^? Optics.key "Pid" - % Optics._Integer of + case lookupKey "Pid" value >>= asInteger of Just pid -> Just (fromIntegral pid) _ -> Nothing @@ -106,9 +98,7 @@ -- @since 0.5.0.0 stateExitCode :: State -> Maybe Int stateExitCode (State value) = - case value - ^? Optics.key "ExitCode" - % Optics._Integer of + case lookupKey "ExitCode" value >>= asInteger of Just exitCode -> Just (fromIntegral exitCode) _ -> Nothing @@ -117,9 +107,7 @@ -- @since 0.5.0.0 stateError :: State -> Maybe Text stateError (State value) = - case value - ^? Optics.key "Error" - % Optics._String of + case lookupKey "Error" value >>= asText of Just err -> Just err _ -> Nothing @@ -128,9 +116,7 @@ -- @since 0.5.0.0 stateStartedAt :: State -> Maybe Text stateStartedAt (State value) = - case value - ^? Optics.key "StartedAt" - % Optics._String of + case lookupKey "StartedAt" value >>= asText of Just err -> Just err _ -> Nothing @@ -139,8 +125,6 @@ -- @since 0.5.0.0 stateFinishedAt :: State -> Maybe Text stateFinishedAt (State value) = - case value - ^? Optics.key "FinishedAt" - % Optics._String of + case lookupKey "FinishedAt" value >>= asText of Just err -> Just err _ -> Nothing diff --git a/testcontainers.cabal b/testcontainers.cabal --- a/testcontainers.cabal +++ b/testcontainers.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: testcontainers -version: 0.5.2.0 +version: 0.5.3.0 synopsis: Docker containers for your integration tests. description: testcontainers is a Haskell library that provides a friendly API to @@ -42,11 +42,10 @@ TestContainers.Tasty TestContainers.Trace - -- other-modules: + other-modules: TestContainers.Docker.JSON -- other-extensions: build-depends: aeson >=1.4.6 && <3 - , aeson-optics >=1.1 && <2 , async , base >=4.12 && <5 , bytestring >=0.10.8 && <0.13 @@ -56,13 +55,14 @@ , http-types >=0.12.3 && <1 , mtl >=2.2.2 && <3 , network >=2.8.0 && <3.3 - , optics-core >=0.1 && <0.5 , process >=1.6.5 && <1.7 , random >=1.2 && <2 , resourcet >=1.2.4 && <1.4 + , scientific >=0.3 && <0.4 , tasty >=1.0 && <1.6 , text >=1.2.3 && <3 , unliftio-core >=0.1.0 && <0.3 + , vector >=0.12 && <0.14 hs-source-dirs: src default-language: Haskell2010