Replace optics-based JSON traversal with lightweight custom helpers

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,
@@ -1022,7 +1020,7 @@
 
     let resolve endpointHost endpointPort = do
           let hints = Socket.defaultHints {Socket.addrSocketType = Socket.Stream}
           head <$> Socket.getAddrInfo (Just hints) (Just endpointHost) (Just (show endpointPort))
 
         open addr = do
           socket <-
@@ -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,50 +1216,42 @@
 -- @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.
 --
 -- @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

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 _ = []

src/TestContainers/Docker/State.hs

@@ -19,11 +19,9 @@ where
 
 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 @@ newtype State = State Value
 -- @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 @@ containerState inspectOutput =
 -- @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 @@ stateStatus (State value) =
 -- @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 @@ stateOOMKilled (State value) =
 -- @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 @@ statePid (State value) =
 -- @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 @@ stateExitCode (State value) =
 -- @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 @@ stateError (State value) =
 -- @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 @@ stateStartedAt (State value) =
 -- @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

testcontainers.cabal

@@ -42,11 +42,10 @@ library
     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 @@ library
     , 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