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
| RequestHeaders
| 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
"/"
]
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
-> (a -> b -> Bool)
-> String
-> a
-> (Request -> b)
-> 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