ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Type ordinary integration probe HTTP traffic

Browse source
This commit is contained in:
ms2k 2026-07-20 23:06:01 +09:00
commit cc5c47f2ce
1 changed files with 1022 additions and 661 deletions
Download patch file Download diff file Expand all files Collapse all files

69
test/Nuthatch/Probe/Curl.hs
View file

@ -1,30 +1,21 @@
module Nuthatch.Probe.Curl
( CurlResponse (..)
, CurlTransportFailure (..)
, cookieValue
( CurlTransportFailure (..)
, curl
, curlToFile
, headerValue
, headerValues
) where
import Control.Exception (Exception, throwIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.Char (toLower)
import Data.List (find)
import qualified Data.CaseInsensitive as CI
import Data.Maybe (mapMaybe)
import Network.HTTP.Types (Header)
import Nuthatch.Probe.Http (ProbeResponse (..))
import System.Exit (ExitCode (..))
import System.IO.Temp (withSystemTempDirectory)
import System.Process (readProcessWithExitCode)
import Text.Read (readMaybe)
data CurlResponse = CurlResponse
{ curlStatus :: Int
, curlHeaders :: [(BS.ByteString, BS.ByteString)]
, curlBody :: BS.ByteString
} deriving stock (Eq, Show)
data CurlTransportFailure = CurlTransportFailure
{ curlTransportExitCode :: Int
, curlTransportStderr :: String
@ -32,19 +23,19 @@ data CurlTransportFailure = CurlTransportFailure
instance Exception CurlTransportFailure
curl :: [String] -> IO CurlResponse
curl :: [String] -> IO ProbeResponse
curl arguments =
withSystemTempDirectory "nuthatch-curl" $ \directory -> do
let bodyPath = directory <> "/body"
response <- runCurl bodyPath arguments
body <- BS.readFile bodyPath
pure response { curlBody = body }
pure response { probeBody = body }
curlToFile :: FilePath -> [String] -> IO CurlResponse
curlToFile :: FilePath -> [String] -> IO ProbeResponse
curlToFile outputPath arguments =
runCurl outputPath arguments
runCurl :: FilePath -> [String] -> IO CurlResponse
runCurl :: FilePath -> [String] -> IO ProbeResponse
runCurl outputPath arguments =
withSystemTempDirectory "nuthatch-curl-headers" $ \directory -> do
let headersPath = directory <> "/headers"
@ -70,13 +61,13 @@ runCurl outputPath arguments =
, curlTransportStderr = stderrText
}
headers <- parseHeaders <$> BS.readFile headersPath
pure CurlResponse
{ curlStatus = status
, curlHeaders = headers
, curlBody = BS.empty
pure ProbeResponse
{ probeStatus = status
, probeHeaders = headers
, probeBody = BS.empty
}
parseHeaders :: BS.ByteString -> [(BS.ByteString, BS.ByteString)]
parseHeaders :: BS.ByteString -> [Header]
parseHeaders input =
case filter (not . null) (splitBlocks (B8.lines input)) of
[] -> []
@ -88,45 +79,15 @@ parseHeaders input =
| otherwise = (stripCarriageReturn line : block) : blocks
splitLine _ [] = []
parseHeader :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
parseHeader :: BS.ByteString -> Maybe Header
parseHeader line =
case B8.break (== ':') line of
(_, remainder) | BS.null remainder -> Nothing
(name, remainder) ->
Just (lower name, B8.dropWhile (== ' ') (BS.drop 1 remainder))
headerValue :: BS.ByteString -> CurlResponse -> Maybe BS.ByteString
headerValue name response =
snd <$> find ((== lower name) . fst) (curlHeaders response)
headerValues :: BS.ByteString -> CurlResponse -> [BS.ByteString]
headerValues name response =
map snd (filter ((== lower name) . fst) (curlHeaders response))
lower :: BS.ByteString -> BS.ByteString
lower = B8.map toLower
Just (CI.mk name, B8.dropWhile (== ' ') (BS.drop 1 remainder))
stripCarriageReturn :: BS.ByteString -> BS.ByteString
stripCarriageReturn value =
case B8.unsnoc value of
Just (prefix, '\r') -> prefix
_ -> value
cookieValue :: FilePath -> BS.ByteString -> IO BS.ByteString
cookieValue path expectedName = do
contents <- B8.lines <$> BS.readFile path
case mapMaybe parseCookie contents of
cookies ->
maybe
(fail ("cookie not found: " <> B8.unpack expectedName))
pure
(lookup expectedName cookies)
parseCookie :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
parseCookie line =
let normalized =
maybe line id (BS.stripPrefix "#HttpOnly_" line)
fields = B8.split '\t' normalized
in case drop 5 fields of
name : value : _ -> Just (name, value)
_ -> Nothing