restman-0.7.5.0: test/BinarySpec.hs

{-# language OverloadedStrings #-}
-- | Acceptance tests that spawn the @restman@ binary and inspect its
-- behaviour via the local echo server.
--
-- These tests require the @restman@ executable to be present on @PATH@.
-- When running via @stack test@, Stack builds the executable first and adds
-- the package bin-dir to @PATH@ automatically.
module BinarySpec (tests) where

-- base
import Data.List (isInfixOf)
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)

-- aeson
import Data.Aeson (FromJSON(..), eitherDecode, withObject, (.:))

-- bytestring
import qualified Data.ByteString.Lazy.Char8 as BL8

-- containers
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

-- directory
import System.Directory (findExecutable)

-- text
import qualified Data.Text as T

-- tasty
import Test.Tasty
import Test.Tasty.HUnit

-- warp
import Network.Wai.Handler.Warp (Port)

-- local
import HTTP.EchoServer (withEchoServer)

-- ---------------------------------------------------------------------------
-- EchoResponse — mirrors the JSON produced by HTTP.EchoServer
-- ---------------------------------------------------------------------------

data EchoResponse = EchoResponse
    { echoMethod :: T.Text
    , echoHeaders :: Map T.Text T.Text
    , echoBody :: T.Text
    } deriving (Eq, Show)

instance FromJSON EchoResponse where
    parseJSON = withObject "EchoResponse" $ \o ->
        EchoResponse
            <$> o .: "method"
            <*> o .: "headers"
            <*> o .: "body"

-- ---------------------------------------------------------------------------
-- Helpers
-- ---------------------------------------------------------------------------

-- | Locate the @restman@ binary on @PATH@, failing the test if it is absent.
findRestmanExe :: IO FilePath
findRestmanExe = do
    mPath <- findExecutable "restman"
    case mPath of
        Nothing -> assertFailure
            "restman binary not found in PATH; run acceptance tests via 'stack test'"
        Just p -> pure p

-- | Run @restman@ with the supplied arguments, returning
-- @(exitCode, stdout, stderr)@.
runRestman :: [String] -> IO (ExitCode, String, String)
runRestman args = do
    exe <- findRestmanExe
    readProcessWithExitCode exe args ""

echoURL :: Port -> String -> String
echoURL port path = "http://localhost:" <> show port <> path

-- | Run @restman --oneshot@ against the local echo server with optional
-- extra arguments, decode the JSON response body, and return the result.
oneshotEcho :: Port -> [String] -> IO EchoResponse
oneshotEcho port extraArgs = do
    let args = extraArgs ++ ["--oneshot", echoURL port "/"]
    (code, out, err) <- runRestman args
    case code of
        ExitFailure n ->
            assertFailure $ "restman exited with code " <> show n
                          <> "; stderr: " <> err
        ExitSuccess ->
            case eitherDecode (BL8.pack out) of
                Left e -> assertFailure
                    $ "Failed to decode echo response: " <> e
                   <> "\nstdout was: " <> out
                Right r -> pure r

-- ---------------------------------------------------------------------------
-- Tests
-- ---------------------------------------------------------------------------

tests :: TestTree
tests = testGroup "Application (acceptance)"
    [ cliTests
    , fetchTests
    ]

cliTests :: TestTree
cliTests = testGroup "CLI"
    [ testCase "--help exits with success and mentions RESTman" $ do
        (code, out, _) <- runRestman ["--help"]
        code @?= ExitSuccess
        assertBool ("expected 'RESTman' in help output\ngot: " <> out)
                   ("RESTman" `isInfixOf` out)

    , testCase "unrecognised flag exits with failure" $ do
        (code, _, _) <- runRestman ["--not-a-real-flag"]
        case code of
            ExitFailure _ -> pure ()
            ExitSuccess -> assertFailure
                "expected non-zero exit for unrecognised flag"

    , testCase "--oneshot without URI exits with failure" $ do
        (code, _, err) <- runRestman ["--oneshot"]
        case code of
            ExitFailure _ ->
                assertBool ("expected 'requires' in error output\ngot: " <> err)
                           ("requires" `isInfixOf` err)
            ExitSuccess ->
                assertFailure
                    "expected non-zero exit when --oneshot has no URI"
    ]

fetchTests :: TestTree
fetchTests = testGroup "fetch (--oneshot)"
    [ testCase "default method is GET" $ withEchoServer $ \port -> do
        er <- oneshotEcho port []
        echoMethod er @?= "GET"

    , testCase "-m DELETE sends DELETE" $ withEchoServer $ \port -> do
        er <- oneshotEcho port ["-m", "DELETE"]
        echoMethod er @?= "DELETE"

    , testCase "-m POST with --payload sends request body" $ withEchoServer $ \port -> do
        er <- oneshotEcho port ["-m", "POST", "--payload", "ping"]
        echoBody er @?= "ping"

    , testCase "-h sends a custom header" $ withEchoServer $ \port -> do
        er <- oneshotEcho port ["-h", "X-Smoke:hello"]
        Map.lookup "x-smoke" (echoHeaders er) @?= Just "hello"

    , testCase "default headers include user-agent" $ withEchoServer $ \port -> do
        er <- oneshotEcho port []
        assertBool "expected 'user-agent' header with default settings"
                   (Map.member "user-agent" (echoHeaders er))

    , testCase "--no-default-headers omits user-agent" $ withEchoServer $ \port -> do
        er <- oneshotEcho port ["--no-default-headers"]
        assertBool "expected 'user-agent' to be absent with --no-default-headers"
                   (Map.notMember "user-agent" (echoHeaders er))
    ]