Split kind tests into component-owned probes

test/Nuthatch/Probe/Curl.hs

@@ -0,0 +1,125 @@
+module Nuthatch.Probe.Curl
+  ( CurlResponse (..)
+  , cookieValue
+  , curl
+  , curlToFile
+  , headerValue
+  , headerValues
+  ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as B8
+import           Data.Char (toLower)
+import           Data.List (find)
+import           Data.Maybe (mapMaybe)
+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)
+
+curl :: [String] -> IO CurlResponse
+curl arguments =
+  withSystemTempDirectory "nuthatch-curl" $ \directory -> do
+    let bodyPath = directory <> "/body"
+    response <- runCurl bodyPath arguments
+    body <- BS.readFile bodyPath
+    pure response { curlBody = body }
+
+curlToFile :: FilePath -> [String] -> IO CurlResponse
+curlToFile outputPath arguments =
+  runCurl outputPath arguments
+
+runCurl :: FilePath -> [String] -> IO CurlResponse
+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 ->
+        fail
+          ( "curl transport failed with exit "
+          <> show code
+          <> ": "
+          <> stderrText
+          )
+    headers <- parseHeaders <$> BS.readFile headersPath
+    pure CurlResponse
+      { curlStatus = status
+      , curlHeaders = headers
+      , curlBody = BS.empty
+      }
+
+parseHeaders :: BS.ByteString -> [(BS.ByteString, BS.ByteString)]
+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 (BS.ByteString, BS.ByteString)
+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
+
+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