nuthatch/test/Nuthatch/Probe/Curl.hs

module Nuthatch.Probe.Curl
  ( CurlTransportFailure (..)
  , curl
  , curlToFile
  ) where

import           Control.Exception (Exception, throwIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
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 CurlTransportFailure = CurlTransportFailure
  { curlTransportExitCode :: Int
  , curlTransportStderr   :: String
  } deriving stock (Eq, Show)

instance Exception CurlTransportFailure

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 { probeBody = body }

curlToFile :: FilePath -> [String] -> IO ProbeResponse
curlToFile outputPath arguments =
  runCurl outputPath arguments

runCurl :: FilePath -> [String] -> IO ProbeResponse
runCurl outputPath arguments =
  withSystemTempDirectory "nuthatch-curl-headers" $ \directory -> do
    let headersPath = directory <> "/headers"
        common =
          [ "--insecure"
          , "--silent"
          , "--show-error"
          , "--dump-header", headersPath
          , "--output", outputPath
          , "--write-out", "%{http_code}"
          ]
    (exitCode, statusText, stderrText) <-
      readProcessWithExitCode "curl" (common <> arguments) ""
    status <- case readMaybe statusText of
      Just value -> pure value
      Nothing ->
        fail ("curl returned an invalid status: " <> statusText)
    case exitCode of
      ExitSuccess -> pure ()
      ExitFailure code ->
        throwIO CurlTransportFailure
          { curlTransportExitCode = code
          , curlTransportStderr = stderrText
          }
    headers <- parseHeaders <$> BS.readFile headersPath
    pure ProbeResponse
      { probeStatus = status
      , probeHeaders = headers
      , probeBody = BS.empty
      }

parseHeaders :: BS.ByteString -> [Header]
parseHeaders input =
  case filter (not . null) (splitBlocks (B8.lines input)) of
    [] -> []
    blocks -> mapMaybe parseHeader (last blocks)
  where
    splitBlocks = foldr splitLine [[]]
    splitLine line (block : blocks)
      | BS.null (stripCarriageReturn line) = [] : block : blocks
      | otherwise = (stripCarriageReturn line : block) : blocks
    splitLine _ [] = []

parseHeader :: BS.ByteString -> Maybe Header
parseHeader line =
  case B8.break (== ':') line of
    (_, remainder) | BS.null remainder -> Nothing
    (name, remainder) ->
      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