Merge pull request #37 from bellroy/allow-ipv6-getaddrinfo

Allow ipv6 getaddrinfo

Author: JackKelly-Bellroy

CHANGELOG.md

@@ -1,5 +1,12 @@
 # Revision history for wai-handler-hal
 
+## 0.4.0.1 -- 2025-02-19
+
+- Use a `NonEmpty` list when consuming the result of `getAddrInfo`.
+- When resolving source IPs, do not require `AF_INET` (IPv4)
+  addresses. This allows IPv6 source addresses to be passed through to
+  the underlying `wai` `Application`.
+
 ## 0.4.0.0 -- 2024-01-17
 
 - New function: `Wai.Handler.Hal.runWithOptions :: Options ->

src/Network/Wai/Handler/Hal.hs

@@ -52,21 +52,23 @@ import qualified AWS.Lambda.Events.ApiGateway.ProxyResponse as HalResponse
 import Control.Exception (IOException, tryJust)
 import Control.Monad.IO.Class (MonadIO (..))
 import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Builder as Builder
 import qualified Data.ByteString.Builder.Extra as Builder
-import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy as LByteString
 import qualified Data.CaseInsensitive as CI
 import Data.Function ((&))
+import Data.Functor ((<&>))
 import Data.HashMap.Lazy (HashMap)
-import qualified Data.HashMap.Lazy as H
+import qualified Data.HashMap.Lazy as HashMap
 import qualified Data.IORef as IORef
 import Data.List (foldl', sort)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 import Data.Vault.Lazy (Key, Vault)
 import qualified Data.Vault.Lazy as Vault
 import Network.HTTP.Media (MediaType, matches, parseAccept, renderHeader)
@@ -160,12 +162,12 @@ runWithOptions ::
   HalRequest.ProxyRequest HalRequest.NoAuthorizer ->
   m HalResponse.ProxyResponse
 runWithOptions opts app req = liftIO $ do
-    waiReq <- toWaiRequest opts req
-    responseRef <- IORef.newIORef Nothing
-    Wai.ResponseReceived <- app waiReq $ \waiResp ->
-      Wai.ResponseReceived <$ IORef.writeIORef responseRef (Just waiResp)
-    Just waiResp <- IORef.readIORef responseRef
-    fromWaiResponse opts waiResp
+  waiReq <- toWaiRequest opts req
+  responseRef <- IORef.newIORef Nothing
+  Wai.ResponseReceived <- app waiReq $ \waiResp ->
+    Wai.ResponseReceived <$ IORef.writeIORef responseRef (Just waiResp)
+  Just waiResp <- IORef.readIORef responseRef
+  fromWaiResponse opts waiResp
 
 -- | Convert a WAI 'Wai.Application' into a function that can
 -- be run by hal's 'AWS.Lambda.Runtime.mRuntimeWithContext'. This
@@ -222,16 +224,17 @@ toWaiRequest ::
   IO Wai.Request
 toWaiRequest opts req = do
   let port = portNumber opts
-      pathSegments = T.splitOn "/" . T.dropWhile (== '/') $ HalRequest.path req
-      query = sort . constructQuery $ HalRequest.multiValueQueryStringParameters req
+      pathSegments =
+        Text.splitOn "/" . Text.dropWhile (== '/') $ HalRequest.path req
+      query =
+        sort . constructQuery $ HalRequest.multiValueQueryStringParameters req
       hints =
         NS.defaultHints
           { NS.addrFlags = [NS.AI_NUMERICHOST],
-            NS.addrFamily = NS.AF_INET,
             NS.addrSocketType = NS.Stream
           }
       sourceIp =
-        T.unpack
+        Text.unpack
           . HalRequest.sourceIp
           . HalRequest.identity
           $ HalRequest.requestContext req
@@ -243,7 +246,7 @@ toWaiRequest opts req = do
       (Just @IOException)
       (NS.getAddrInfo (Just hints) (Just sourceIp) (Just $ show port))
       >>= \case
-        Right (s : _) -> pure $ NS.addrAddress s
+        Right (s :| _) -> pure $ NS.addrAddress s
         _ -> do
           hPutStrLn stderr $
             mconcat
@@ -253,53 +256,57 @@ toWaiRequest opts req = do
               ]
           pure . NS.SockAddrInet port $ NS.tupleToHostAddress (127, 0, 0, 1)
   body <- returnChunks $ HalRequest.body req
-  let waiReq =
-        Wai.Request
-          { Wai.requestMethod = T.encodeUtf8 $ HalRequest.httpMethod req,
-            Wai.httpVersion = HttpVersion 1 1,
-            Wai.rawPathInfo =
-              BL.toStrict
-                . Builder.toLazyByteString
-                $ encodePath pathSegments [],
-            Wai.rawQueryString = case query of
-              [] -> ""
-              _ -> renderQuery True query,
-            Wai.requestHeaders =
-              sort
-                . foldMap
-                  ( \(hName, hValues) ->
-                      (CI.map T.encodeUtf8 hName,) . T.encodeUtf8 <$> hValues
-                  )
-                . H.toList
-                $ HalRequest.multiValueHeaders req,
-            Wai.isSecure = True,
-            Wai.remoteHost = sourceHost,
-            Wai.pathInfo = pathSegments,
-            Wai.queryString = query,
-            Wai.requestBody = body,
-            Wai.vault = vault opts,
-            Wai.requestBodyLength =
-              Wai.KnownLength . fromIntegral . BL.length $ HalRequest.body req,
-            Wai.requestHeaderHost = getHeader hHost req,
-            Wai.requestHeaderRange = getHeader hRange req,
-            Wai.requestHeaderReferer = getHeader hReferer req,
-            Wai.requestHeaderUserAgent = getHeader hUserAgent req
-          }
-  pure waiReq
+  pure
+    Wai.Request
+      { Wai.requestMethod = Text.encodeUtf8 $ HalRequest.httpMethod req,
+        Wai.httpVersion = HttpVersion 1 1,
+        Wai.rawPathInfo =
+          LByteString.toStrict
+            . Builder.toLazyByteString
+            $ encodePath pathSegments [],
+        Wai.rawQueryString = case query of
+          [] -> ""
+          _ -> renderQuery True query,
+        Wai.requestHeaders =
+          sort
+            . foldMap
+              ( \(hName, hValues) ->
+                  hValues <&> \hValue ->
+                    (CI.map Text.encodeUtf8 hName, Text.encodeUtf8 hValue)
+              )
+            . HashMap.toList
+            $ HalRequest.multiValueHeaders req,
+        Wai.isSecure = True,
+        Wai.remoteHost = sourceHost,
+        Wai.pathInfo = pathSegments,
+        Wai.queryString = query,
+        Wai.requestBody = body,
+        Wai.vault = vault opts,
+        Wai.requestBodyLength =
+          Wai.KnownLength
+            . fromIntegral
+            . LByteString.length
+            $ HalRequest.body req,
+        Wai.requestHeaderHost = getHeader hHost req,
+        Wai.requestHeaderRange = getHeader hRange req,
+        Wai.requestHeaderReferer = getHeader hReferer req,
+        Wai.requestHeaderUserAgent = getHeader hUserAgent req
+      }
 
--- | Unpack a lazy 'BL.ByteString' into its chunks, and return an IO
--- action which returns each chunk in sequence, and returns 'B.empty'
--- forever after the bytestring is exhausted.
-returnChunks :: BL.ByteString -> IO (IO B.ByteString)
+-- | Unpack a lazy 'LByteString.ByteString' into its chunks, and
+-- return an IO action which returns each chunk in sequence, and
+-- returns 'ByteString.empty' forever after the bytestring is
+-- exhausted.
+returnChunks :: LByteString.ByteString -> IO (IO ByteString.ByteString)
 returnChunks bs = do
-  chunkRef <- IORef.newIORef $ BL.toChunks bs
+  chunkRef <- IORef.newIORef $ LByteString.toChunks bs
   pure . IORef.atomicModifyIORef' chunkRef $
     \case
       [] -> mempty
       (ch : chs) -> (chs, ch)
 
 constructQuery :: HashMap Text [Text] -> Query
-constructQuery = foldMap expandParamList . H.toList
+constructQuery = foldMap expandParamList . HashMap.toList
   where
     expandParamList :: (Text, [Text]) -> [QueryItem]
     expandParamList (param, values) =
@@ -309,7 +316,9 @@ constructQuery = foldMap expandParamList . H.toList
 
 getHeader :: HeaderName -> HalRequest.ProxyRequest a -> Maybe ByteString
 getHeader h =
-  fmap T.encodeUtf8 . H.lookup (CI.map T.decodeUtf8 h) . HalRequest.headers
+  fmap Text.encodeUtf8
+    . HashMap.lookup (CI.map Text.decodeUtf8 h)
+    . HalRequest.headers
 
 -- | Convert a WAI 'Wai.Response' into a hal
 -- 'HalResponse.ProxyResponse'.
@@ -326,7 +335,7 @@ fromWaiResponse opts (Wai.ResponseBuilder status headers builder) =
     . addHeaders headers
     . HalResponse.response status
     . createProxyBody opts (getContentType headers)
-    . BL.toStrict
+    . LByteString.toStrict
     $ Builder.toLazyByteString builder
 fromWaiResponse opts (Wai.ResponseStream status headers stream) = do
   builderRef <- IORef.newIORef mempty
@@ -340,19 +349,19 @@ fromWaiResponse opts (Wai.ResponseRaw _ resp) = fromWaiResponse opts resp
 readFilePart :: FilePath -> Maybe Wai.FilePart -> IO ByteString
 readFilePart path mPart = withFile path ReadMode $ \h -> do
   case mPart of
-    Nothing -> B.hGetContents h
+    Nothing -> ByteString.hGetContents h
     Just (Wai.FilePart offset count _) -> do
       hSeek h AbsoluteSeek offset
-      B.hGet h $ fromIntegral count
+      ByteString.hGet h $ fromIntegral count
 
 createProxyBody :: Options -> MediaType -> ByteString -> HalResponse.ProxyBody
 createProxyBody opts contentType body =
   HalResponse.ProxyBody
-    { HalResponse.contentType = T.decodeUtf8 $ renderHeader contentType,
+    { HalResponse.contentType = Text.decodeUtf8 $ renderHeader contentType,
       HalResponse.serialized =
         if isBase64Encoded
-          then T.decodeUtf8 $ B64.encode body
-          else T.decodeUtf8 body,
+          then Text.decodeUtf8 $ Base64.encode body
+          else Text.decodeUtf8 body,
       HalResponse.isBase64Encoded
     }
   where
@@ -364,8 +373,8 @@ addHeaders headers response = foldl' addHeader response headers
   where
     addHeader r (hName, hValue) =
       HalResponse.addHeader
-        (T.decodeUtf8 $ CI.original hName)
-        (T.decodeUtf8 hValue)
+        (Text.decodeUtf8 $ CI.original hName)
+        (Text.decodeUtf8 hValue)
         r
 
 -- | Try to find the content-type of a response, given the response

wai-handler-hal.cabal

@@ -56,7 +56,7 @@ common deps
     , hal                   >=0.4.7     && <0.4.11 || >=1.0.0 && <1.2
     , http-media            ^>=0.8.1.1
     , http-types            ^>=0.12.3
-    , network               >=2.8.0.0   && <3.3
+    , network               >=3.2.3.0   && <3.3
     , text                  ^>=1.2.3    || ^>=2.0  || ^>=2.1
     , unordered-containers  ^>=0.2.10.0
     , vault                 ^>=0.3.1.0