-- | '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 Freckle.App.Prelude

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import Data.List (isPrefixOf)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Network.HTTP.Client (Request, RequestBody (..), parseRequest_)
import qualified Network.HTTP.Client.Internal 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 ((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) ([Maybe Int] -> Bool) -> [Maybe Int] -> Bool
forall a b. (a -> b) -> a -> b
$
    [[Maybe Int]] -> [Maybe Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [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
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) 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  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) 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  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) (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