-- | 'Request' predicates for matching 'HttpStub's
--
-- == Usage
--
-- @
-- stubs :: ['HttpStub']
-- stubs =
--   [ \"https://example.com\"
--       & 'matchL' <>~ 'MatchMethod' \"POST\"
--       & 'matchL' <>~ 'MatchHeaders' [(hAccept, \"text/plain+csv\")]
--       & 'matchL' <>~ 'MatchBody' \"id,name\n42,Pat\n\"
--       & 'statusL' .~ 'status201'
--       & 'bodyL' .~ \"OK\n\"
--   ]
-- @
module Freckle.App.Test.Http.MatchRequest
  ( MatchRequest (..)
  , matchRequestFromUrl
  , matchRequest
  , showMatchRequest
  , showMatchRequestWithMismatches
  ) where

import Prelude

import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as BSL
import Data.Foldable (toList)
import Data.List (isPrefixOf)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Maybe (catMaybes)
import Data.Semigroup.Foldable (fold1)
import Network.HTTP.Client (Request, RequestBody (..), parseRequest_)
import Network.HTTP.Client.Internal qualified as HTTP
import Network.HTTP.Types.Header (Header, RequestHeaders)
import Network.HTTP.Types.Method (Method)

data MatchRequest
  = MatchAnything
  | MatchAnd MatchRequest MatchRequest
  | MatchMethod Method
  | MatchSecure Bool
  | MatchHost ByteString
  | MatchPort Int
  | MatchPath ByteString
  | MatchQuery ByteString
  | MatchHeaders RequestHeaders
  | MatchHeader Header
  | MatchBody ByteString
  deriving stock (Int -> MatchRequest -> ShowS
[MatchRequest] -> ShowS
MatchRequest -> String
(Int -> MatchRequest -> ShowS)
-> (MatchRequest -> String)
-> ([MatchRequest] -> ShowS)
-> Show MatchRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MatchRequest -> ShowS
showsPrec :: Int -> MatchRequest -> ShowS
$cshow :: MatchRequest -> String
show :: MatchRequest -> String
$cshowList :: [MatchRequest] -> ShowS
showList :: [MatchRequest] -> ShowS
Show)

instance Semigroup MatchRequest where
  MatchRequest
a <> :: MatchRequest -> MatchRequest -> MatchRequest
<> MatchRequest
b = MatchRequest -> MatchRequest -> MatchRequest
MatchAnd MatchRequest
a MatchRequest
b

matchRequestFromUrl :: String -> MatchRequest
matchRequestFromUrl :: String -> MatchRequest
matchRequestFromUrl String
url =
  NonEmpty MatchRequest -> MatchRequest
forall m. Semigroup m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable1 t, Semigroup m) => t m -> m
fold1 (NonEmpty MatchRequest -> MatchRequest)
-> NonEmpty MatchRequest -> MatchRequest
forall a b. (a -> b) -> a -> b
$ (NonEmpty MatchRequest -> NonEmpty MatchRequest)
-> (NonEmpty MatchRequest
    -> NonEmpty MatchRequest -> NonEmpty MatchRequest)
-> Maybe (NonEmpty MatchRequest)
-> NonEmpty MatchRequest
-> NonEmpty MatchRequest
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NonEmpty MatchRequest -> NonEmpty MatchRequest
forall a. a -> a
id NonEmpty MatchRequest
-> NonEmpty MatchRequest -> NonEmpty MatchRequest
forall a. Semigroup a => a -> a -> a
(<>) Maybe (NonEmpty MatchRequest)
optionalMatches NonEmpty MatchRequest
requiredMatches
 where
  req :: Request
req = String -> Request
parseRequest_ String
url

  method :: Method
method = Request -> Method
HTTP.method Request
req
  secure :: Bool
secure = Request -> Bool
HTTP.secure Request
req
  host :: Method
host = Request -> Method
HTTP.host Request
req
  port :: Int
port = Request -> Int
HTTP.port Request
req
  path :: Method
path = Request -> Method
HTTP.path Request
req
  query :: Method
query = Request -> Method
HTTP.queryString Request
req
  headers :: RequestHeaders
headers = Request -> RequestHeaders
HTTP.requestHeaders Request
req
  body :: Method
body = Request -> Method
simplifyRequestBody Request
req

  requiredMatches :: NonEmpty MatchRequest
requiredMatches = Method -> MatchRequest
MatchMethod Method
method MatchRequest -> [MatchRequest] -> NonEmpty MatchRequest
forall a. a -> [a] -> NonEmpty a
:| [Bool -> MatchRequest
MatchSecure Bool
secure, Int -> MatchRequest
MatchPort Int
port]

  optionalMatches :: Maybe (NonEmpty MatchRequest)
optionalMatches =
    [MatchRequest] -> Maybe (NonEmpty MatchRequest)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([MatchRequest] -> Maybe (NonEmpty MatchRequest))
-> [MatchRequest] -> Maybe (NonEmpty MatchRequest)
forall a b. (a -> b) -> a -> b
$
      [Maybe MatchRequest] -> [MatchRequest]
forall a. [Maybe a] -> [a]
catMaybes
        [ Method -> MatchRequest
MatchHost Method
host MatchRequest -> Maybe () -> Maybe MatchRequest
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Method
host Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
/= Method
"")
        , Method -> MatchRequest
MatchPath Method
path MatchRequest -> Maybe () -> Maybe MatchRequest
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Method -> Int -> String -> Bool
hasExplicitPath Bool
secure Method
host Int
port String
url)
        , Method -> MatchRequest
MatchQuery Method
query MatchRequest -> Maybe () -> Maybe MatchRequest
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Method
query Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
/= Method
"")
        , RequestHeaders -> MatchRequest
MatchHeaders RequestHeaders
headers MatchRequest -> Maybe () -> Maybe MatchRequest
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RequestHeaders
headers)
        , Method -> MatchRequest
MatchBody Method
body MatchRequest -> Maybe () -> Maybe MatchRequest
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Method
body Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
/= Method
"")
        ]

hasExplicitPath :: Bool -> ByteString -> Int -> String -> Bool
hasExplicitPath :: Bool -> Method -> Int -> String -> Bool
hasExplicitPath Bool
secure Method
host Int
port String
url =
  ([Maybe Int] -> Bool) -> [[Maybe Int]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
    ((Maybe Int -> Bool) -> [Maybe Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
url) (String -> Bool) -> (Maybe Int -> String) -> Maybe Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> String
toUrlPrefix))
    [ [Int -> Maybe Int
forall a. a -> Maybe a
Just Int
port]
    , Maybe Int
forall a. Maybe a
Nothing Maybe Int -> [()] -> [Maybe Int]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool
secure Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443)
    , Maybe Int
forall a. Maybe a
Nothing Maybe Int -> [()] -> [Maybe Int]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
secure Bool -> Bool -> Bool
&& Int
port Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
80)
    ]
 where
  toUrlPrefix :: Maybe Int -> String
toUrlPrefix Maybe Int
mport =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"http"
      , if Bool
secure then String
"s" else String
""
      , String
"://"
      , Method -> String
BS8.unpack Method
host
      , String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String
":" <>) ShowS -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) Maybe Int
mport
      , String
"/"
      ]

-- | Match a 'Request'
--
-- Success is @'Right' ()@, failure is a message in 'Left'.
matchRequest :: Request -> MatchRequest -> Either String ()
matchRequest :: Request -> MatchRequest -> Either String ()
matchRequest Request
req MatchRequest
mr =
  Either String ()
-> (NonEmpty String -> Either String ())
-> Maybe (NonEmpty String)
-> Either String ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either String ()
forall a b. b -> Either a b
Right ()) (String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ())
-> (NonEmpty String -> String)
-> NonEmpty String
-> Either String ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchRequest -> NonEmpty String -> String
showMatchRequestWithMismatches MatchRequest
mr) (Maybe (NonEmpty String) -> Either String ())
-> Maybe (NonEmpty String) -> Either String ()
forall a b. (a -> b) -> a -> b
$
    Request -> MatchRequest -> Maybe (NonEmpty String)
buildMismatch Request
req MatchRequest
mr

showMatchRequest :: MatchRequest -> String
showMatchRequest :: MatchRequest -> String
showMatchRequest MatchRequest
mr =
  String
"MatchRequest {"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (MatchRequest -> String) -> [MatchRequest] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String
"\n  " <>) ShowS -> (MatchRequest -> String) -> MatchRequest -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchRequest -> String
forall a. Show a => a -> String
show) (MatchRequest -> [MatchRequest]
flattenMatchRequest MatchRequest
mr)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n}"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"

showMatchRequestWithMismatches :: MatchRequest -> NonEmpty String -> String
showMatchRequestWithMismatches :: MatchRequest -> NonEmpty String -> String
showMatchRequestWithMismatches MatchRequest
mr NonEmpty String
mismatches =
  MatchRequest -> String
showMatchRequest MatchRequest
mr
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nMismatches {"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String
"\n  " <>) (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty String
mismatches)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n}"
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"

flattenMatchRequest :: MatchRequest -> [MatchRequest]
flattenMatchRequest :: MatchRequest -> [MatchRequest]
flattenMatchRequest = \case
  MatchAnd MatchRequest
a MatchRequest
b -> MatchRequest -> [MatchRequest]
flattenMatchRequest MatchRequest
a [MatchRequest] -> [MatchRequest] -> [MatchRequest]
forall a. Semigroup a => a -> a -> a
<> MatchRequest -> [MatchRequest]
flattenMatchRequest MatchRequest
b
  MatchRequest
x -> [MatchRequest
x]

buildMismatch :: Request -> MatchRequest -> Maybe (NonEmpty String)
buildMismatch :: Request -> MatchRequest -> Maybe (NonEmpty String)
buildMismatch Request
req = \case
  MatchRequest
MatchAnything -> Maybe (NonEmpty String)
forall a. Maybe a
Nothing
  MatchAnd MatchRequest
a MatchRequest
b -> Request -> MatchRequest -> Maybe (NonEmpty String)
buildMismatch Request
req MatchRequest
a Maybe (NonEmpty String)
-> Maybe (NonEmpty String) -> Maybe (NonEmpty String)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Request -> MatchRequest -> Maybe (NonEmpty String)
buildMismatch Request
req MatchRequest
b
  MatchMethod Method
m -> String
-> (Method -> Method -> Bool)
-> String
-> Method
-> (Request -> Method)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"!=" Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"method" Method
m Request -> Method
HTTP.method Request
req
  MatchSecure Bool
s -> String
-> (Bool -> Bool -> Bool)
-> String
-> Bool
-> (Request -> Bool)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"!=" Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"secure" Bool
s Request -> Bool
HTTP.secure Request
req
  MatchHost Method
h -> String
-> (Method -> Method -> Bool)
-> String
-> Method
-> (Request -> Method)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"!=" Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"host" Method
h Request -> Method
HTTP.host Request
req
  MatchPort Int
p -> String
-> (Int -> Int -> Bool)
-> String
-> Int
-> (Request -> Int)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"!=" Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"port" Int
p Request -> Int
HTTP.port Request
req
  MatchPath Method
p -> String
-> (Method -> Method -> Bool)
-> String
-> Method
-> (Request -> Method)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"!=" Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"path" Method
p (Method -> Method
ensureLeadingSlash (Method -> Method) -> (Request -> Method) -> Request -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Method
HTTP.path) Request
req
  MatchQuery Method
q -> String
-> (Method -> Method -> Bool)
-> String
-> Method
-> (Request -> Method)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"!=" Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"query" Method
q Request -> Method
HTTP.queryString Request
req
  MatchHeaders RequestHeaders
hs -> String
-> (RequestHeaders -> RequestHeaders -> Bool)
-> String
-> RequestHeaders
-> (Request -> RequestHeaders)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"!=" RequestHeaders -> RequestHeaders -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"headers" RequestHeaders
hs Request -> RequestHeaders
HTTP.requestHeaders Request
req
  MatchHeader Header
h -> String
-> (Header -> RequestHeaders -> Bool)
-> String
-> Header
-> (Request -> RequestHeaders)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"not in" Header -> RequestHeaders -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
"header" Header
h Request -> RequestHeaders
HTTP.requestHeaders Request
req
  MatchBody Method
bs -> String
-> (Method -> Method -> Bool)
-> String
-> Method
-> (Request -> Method)
-> Request
-> Maybe (NonEmpty String)
forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
"!=" Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
"body" Method
bs Request -> Method
simplifyRequestBody Request
req

propMismatch
  :: (Show a, Show b)
  => String
  -- ^ Label to show infix when comparison fails, e.g. "!="
  -> (a -> b -> Bool)
  -- ^ How to compare values
  -> String
  -- ^ Label for the property itself
  -> a
  -- ^ Value to compare to property
  -> (Request -> b)
  -- ^ Function to get property from 'Request'
  -> Request
  -> Maybe (NonEmpty String)
propMismatch :: forall a b.
(Show a, Show b) =>
String
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> Request
-> Maybe (NonEmpty String)
propMismatch String
opLabel a -> b -> Bool
op String
propLabel a
a Request -> b
f Request
req
  | a
a a -> b -> Bool
`op` b
b = Maybe (NonEmpty String)
forall a. Maybe a
Nothing
  | Bool
otherwise = NonEmpty String -> Maybe (NonEmpty String)
forall a. a -> Maybe a
Just (NonEmpty String -> Maybe (NonEmpty String))
-> NonEmpty String -> Maybe (NonEmpty String)
forall a b. (a -> b) -> a -> b
$ String -> NonEmpty String
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
msg
 where
  b :: b
b = Request -> b
f Request
req
  msg :: String
msg =
    String
"✗ "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
propLabel
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
a
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
opLabel
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> b -> String
forall a. Show a => a -> String
show b
b

simplifyRequestBody :: Request -> ByteString
simplifyRequestBody :: Request -> Method
simplifyRequestBody = RequestBody -> Method
go (RequestBody -> Method)
-> (Request -> RequestBody) -> Request -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> RequestBody
HTTP.requestBody
 where
  go :: RequestBody -> Method
go = \case
    RequestBodyLBS ByteString
lbs -> ByteString -> Method
BSL.toStrict ByteString
lbs
    RequestBodyBS Method
bs -> Method
bs
    RequestBody
_ -> Method
""

ensureLeadingSlash :: ByteString -> ByteString
ensureLeadingSlash :: Method -> Method
ensureLeadingSlash Method
bs
  | Just (Char
'/', Method
_) <- Method -> Maybe (Char, Method)
BS8.uncons Method
bs = Method
bs
  | Bool
otherwise = Char -> Method -> Method
BS8.cons Char
'/' Method
bs