content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE QuasiQuotes #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE NoMonomorphismRestriction #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Network.HTTP.ReqSpec (spec) where
  
  import Blaze.ByteString.Builder qualified as BB
  import Control.Exception (throwIO)
  import Control.Monad
  import Control.Retry
  import Data.Aeson (ToJSON (..))
  import Data.Aeson qualified as A
  import Data.ByteString (ByteString)
  import Data.ByteString qualified as B
  import Data.ByteString.Char8 qualified as B8
  import Data.ByteString.Lazy qualified as BL
  import Data.CaseInsensitive qualified as CI
  import Data.Either (isRight)
  import Data.List.NonEmpty qualified as NE
  import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
  import Data.Proxy
  import Data.Text (Text)
  import Data.Text qualified as T
  import Data.Text.Encoding qualified as T
  import Data.Time
  import Data.Typeable (Typeable, eqT)
  import GHC.Exts (IsList (..))
  import GHC.Generics
  import Language.Haskell.TH qualified as TH
  import Language.Haskell.TH.Quote qualified as TH
  import Network.HTTP.Client qualified as L
  import Network.HTTP.Req
  import Network.HTTP.Types qualified as Y
  import Network.HTTP.Types.Header qualified as Y
  import Test.Hspec
  import Test.Hspec.Core.Spec (SpecM)
  import Test.QuickCheck
  import Text.URI (URI)
  import Text.URI qualified as URI
  import Text.URI.QQ qualified as QQ
  import Web.FormUrlEncoded qualified as F
  
  spec :: Spec
  spec = do
    describe "config" $
      it "getHttpConfig has effect on resulting request" $
        property $ \config -> do
          request <- runReq config (req_ GET url NoReqBody mempty)
          L.proxy request `shouldBe` httpConfigProxy config
          L.redirectCount request `shouldBe` httpConfigRedirectCount config
  
    describe "methods" $ do
      let mnth ::
            forall method.
            ( HttpMethod method,
              HttpBodyAllowed (AllowsBody method) 'NoBody
            ) =>
            method ->
            SpecM () ()
          mnth method = do
            let name = httpMethodName (Proxy :: Proxy method)
            describe (B8.unpack name) $
              it "affects name of HTTP method" $ do
                request <- req_ method url NoReqBody mempty
                L.method request `shouldBe` name
      mnth GET
      mnth POST
      mnth HEAD
      mnth PUT
      mnth DELETE
      mnth TRACE
      mnth CONNECT
      mnth OPTIONS
      mnth PATCH
  
    describe "urls" $ do
      describe "http" $
        it "sets all the params correctly" $
          property $ \host -> do
            request <- req_ GET (http host) NoReqBody mempty
            L.secure request `shouldBe` False
            L.port request `shouldBe` 80
            L.host request `shouldBe` urlEncode host
      describe "https" $
        it "sets all the params correctly" $
          property $ \host -> do
            request <- req_ GET (https host) NoReqBody mempty
            L.secure request `shouldBe` True
            L.port request `shouldBe` 443
            L.host request `shouldBe` urlEncode host
      describe "(/~)" $
        it "attaches a path piece that is URL-encoded" $
          property $ \host pieces -> do
            let url' = foldl (/~) (https host) pieces
            request <- req_ GET url' NoReqBody mempty
            L.host request `shouldBe` urlEncode host
            L.path request `shouldBe` encodePathPieces pieces
      describe "(/:)" $
        it "attaches a path piece that is URL-encoded" $
          property $ \host pieces -> do
            let url' = foldl (/:) (https host) pieces
            request <- req_ GET url' NoReqBody mempty
            L.host request `shouldBe` urlEncode host
            L.path request `shouldBe` encodePathPieces pieces
  
      describe "useHttpURI" $ do
        it "does not recognize non-http schemes" $
          property $ \uri ->
            when (URI.uriScheme uri /= Just [QQ.scheme|http|]) $
              useHttpURI uri `shouldSatisfy` isNothing
        it "accepts correct URLs" $
          property $ \uri' -> do
            unless (isRight (URI.uriAuthority uri')) discard
            let uri = uri' {URI.uriScheme = Just [QQ.scheme|http|]}
                (url', options) = fromJust (useHttpURI uri)
            request <- req_ GET url' NoReqBody options
            L.host request `shouldBe` uriHost uri
            L.port request `shouldBe` uriPort 80 uri
            L.path request `shouldBe` uriPath uri
            L.queryString request `shouldBe` uriQuery uri
            lookup "Authorization" (L.requestHeaders request)
              `shouldBe` uriBasicAuth uri
      describe "useHttpsURI" $ do
        it "does not recognize non-https schemes" $
          property $ \uri ->
            when (URI.uriScheme uri /= Just [QQ.scheme|https|]) $
              useHttpsURI uri `shouldSatisfy` isNothing
        it "parses correct URLs" $
          property $ \uri' -> do
            unless (isRight (URI.uriAuthority uri')) discard
            let uri = uri' {URI.uriScheme = Just [QQ.scheme|https|]}
                (url', options) = fromJust (useHttpsURI uri)
            request <- req_ GET url' NoReqBody options
            L.host request `shouldBe` uriHost uri
            L.port request `shouldBe` uriPort 443 uri
            L.path request `shouldBe` uriPath uri
            L.queryString request `shouldBe` uriQuery uri
            lookup "Authorization" (L.requestHeaders request)
              `shouldBe` uriBasicAuth uri
      describe "useURI" $ do
        it "does not recognize non-http and non-https schemes" $
          property $ \uri ->
            when
              ( ( URI.uriScheme uri /= Just [QQ.scheme|http|]
                    && (URI.uriScheme uri /= Just [QQ.scheme|https|])
                )
              )
              $ useURI uri `shouldSatisfy` isNothing
        it "parses correct URLs" $
          property $ \uri' -> do
            unless (isRight (URI.uriAuthority uri')) discard
            let uriHttp = uri' {URI.uriScheme = Just [QQ.scheme|http|]}
                uriHttps = uri' {URI.uriScheme = Just [QQ.scheme|https|]}
            requestHttp <-
              case fromJust (useURI uriHttp) of
                Left (url', options) -> req_ GET url' NoReqBody options
                _ -> error "(useURI uriHttp) should have returned Left"
            requestHttps <-
              case fromJust (useURI uriHttps) of
                Right (url', options) -> req_ GET url' NoReqBody options
                _ -> error "(useURI uriHttps) should have returned Right"
            L.host requestHttp `shouldBe` uriHost uriHttp
            L.host requestHttps `shouldBe` uriHost uriHttps
            L.port requestHttp `shouldBe` uriPort 80 uriHttp
            L.port requestHttps `shouldBe` uriPort 443 uriHttps
            L.path requestHttp `shouldBe` uriPath uriHttp
            L.path requestHttps `shouldBe` uriPath uriHttps
            L.queryString requestHttp `shouldBe` uriQuery uriHttp
            L.queryString requestHttps `shouldBe` uriQuery uriHttps
            lookup "Authorization" (L.requestHeaders requestHttp)
              `shouldBe` uriBasicAuth uriHttp
            lookup "Authorization" (L.requestHeaders requestHttps)
              `shouldBe` uriBasicAuth uriHttps
  
      describe "renderUrl" $ do
        context "http" $ do
          context "empty path" $
            it "renders correctly" $ do
              let (uriHttp, _) = [urlQ|http://httpbin.org|]
              renderUrl uriHttp `shouldBe` "http://httpbin.org"
          context "non-empty path" $
            it "renders correctly" $ do
              let (uriHttp, _) = [urlQ|http://httpbin.org/here/we/go|]
              renderUrl uriHttp `shouldBe` "http://httpbin.org/here/we/go"
        context "http" $ do
          context "empty path" $
            it "renders correctly" $ do
              let (uriHttp, _) = [urlQ|https://httpbin.org|]
              renderUrl uriHttp `shouldBe` "https://httpbin.org"
          context "non-empty path" $
            it "renders correctly" $ do
              let (uriHttp, _) = [urlQ|https://httpbin.org/here/we/go|]
              renderUrl uriHttp `shouldBe` "https://httpbin.org/here/we/go"
  
    describe "bodies" $ do
      describe "NoReqBody" $
        it "sets body to empty byte string" $ do
          request <- req_ POST url NoReqBody mempty
          case L.requestBody request of
            L.RequestBodyBS x -> x `shouldBe` B.empty
            _ -> expectationFailure "Wrong request body constructor."
      describe "ReqBodyJson" $
        it "sets body to correct lazy byte string" $
          property $ \thing -> do
            request <- req_ POST url (ReqBodyJson thing) mempty
            case L.requestBody request of
              L.RequestBodyLBS x -> x `shouldBe` A.encode (thing :: Thing)
              _ -> expectationFailure "Wrong request body constructor."
      describe "ReqBodyBs" $
        it "sets body to specified strict byte string" $
          property $ \bs -> do
            request <- req_ POST url (ReqBodyBs bs) mempty
            case L.requestBody request of
              L.RequestBodyBS x -> x `shouldBe` bs
              _ -> expectationFailure "Wrong request body constructor."
      describe "ReqBodyLbs" $
        it "sets body to specified lazy byte string" $
          property $ \lbs -> do
            request <- req_ POST url (ReqBodyLbs lbs) mempty
            case L.requestBody request of
              L.RequestBodyLBS x -> x `shouldBe` lbs
              _ -> expectationFailure "Wrong request body constructor."
      describe "ReqBodyUrlEnc" $
        it "sets body to correct lazy byte string" $
          property $ \params -> do
            request <- req_ POST url (ReqBodyUrlEnc (formUrlEnc params)) mempty
            case L.requestBody request of
              L.RequestBodyLBS x -> x `shouldBe` renderQuery params
              _ -> expectationFailure "Wrong request body constructor."
  
    describe "query params" $ do
      describe "FormUrlEncodedParam" $ do
        describe "formToQuery" $ do
          it "should produce the same parameters as F.urlEncodeFormStable" $
            property $ \form -> do
              request <- req_ POST url (ReqBodyUrlEnc $ formToQuery form) mempty
              case L.requestBody request of
                L.RequestBodyLBS x -> x `shouldBe` F.urlEncodeFormStable form
                _ -> expectationFailure "Wrong request body constructor"
        specParamToList (Proxy :: Proxy FormUrlEncodedParam)
      describe "Option" $ do
        specParamToList (Proxy :: Proxy (Option 'Http))
  
    describe "optional parameters" $ do
      describe "header" $ do
        it "sets specified header value" $
          property $ \name value -> do
            request <- req_ GET url NoReqBody (header name value)
            lookup (CI.mk name) (L.requestHeaders request) `shouldBe` pure value
        it "left header wins" $
          property $ \name value0 value1 -> do
            request <-
              req_
                GET
                url
                NoReqBody
                (header name value0 <> header name value1)
            lookup (CI.mk name) (L.requestHeaders request) `shouldBe` pure value0
        it "overwrites headers set by other parts of the lib" $
          property $ \value -> do
            request <-
              req_
                POST
                url
                (ReqBodyUrlEnc mempty)
                (header "Content-Type" value)
            lookup "Content-Type" (L.requestHeaders request) `shouldBe` pure value
      describe "cookieJar" $
        it "cookie jar is set without modifications" $
          property $ \cjar -> do
            request <- req_ GET url NoReqBody (cookieJar cjar)
            L.cookieJar request `shouldSatisfy` (maybe False (L.equalCookieJar cjar))
      describe "basicAuth" $ do
        it "sets Authorization header to correct value" $
          property $ \username password -> do
            request <- req_ GET url NoReqBody (basicAuth username password)
            lookup "Authorization" (L.requestHeaders request)
              `shouldBe` Just (basicAuthHeader username password)
        it "overwrites manual setting of header" $
          property $ \username password value -> do
            request0 <-
              req_
                GET
                url
                NoReqBody
                (basicAuth username password <> header "Authorization" value)
            request1 <-
              req_
                GET
                url
                NoReqBody
                (header "Authorization" value <> basicAuth username password)
            let result = Just (basicAuthHeader username password)
            lookup "Authorization" (L.requestHeaders request0) `shouldBe` result
            lookup "Authorization" (L.requestHeaders request1) `shouldBe` result
        it "left auth option wins" $
          property $ \username0 password0 username1 password1 -> do
            request <-
              req_
                GET
                url
                NoReqBody
                (basicAuth username0 password0 <> basicAuth username1 password1)
            lookup "Authorization" (L.requestHeaders request)
              `shouldBe` Just (basicAuthHeader username0 password0)
      describe "oAuth2Bearer" $ do
        it "sets Authorization header to correct value" $
          property $ \token -> do
            request <- req_ GET url NoReqBody (oAuth2Bearer token)
            lookup "Authorization" (L.requestHeaders request)
              `shouldBe` pure ("Bearer " <> token)
        it "overwrites manual setting of header" $
          property $ \token value -> do
            request0 <-
              req_
                GET
                url
                NoReqBody
                (oAuth2Bearer token <> header "Authorization" value)
            request1 <-
              req_
                GET
                url
                NoReqBody
                (header "Authorization" value <> oAuth2Bearer token)
            let result = "Bearer " <> token
            lookup "Authorization" (L.requestHeaders request0)
              `shouldBe` pure result
            lookup "Authorization" (L.requestHeaders request1)
              `shouldBe` pure result
        it "left auth option wins" $
          property $ \token0 token1 -> do
            request <-
              req_
                GET
                url
                NoReqBody
                (oAuth2Bearer token0 <> oAuth2Bearer token1)
            lookup "Authorization" (L.requestHeaders request)
              `shouldBe` pure ("Bearer " <> token0)
      describe "ProxyAuthorization" $
        it "sets Authorization header to correct value" $
          property $ \username password -> do
            request <- req_ GET url NoReqBody (basicProxyAuth username password)
            lookup "Proxy-Authorization" (L.requestHeaders request)
              `shouldBe` pure (basicProxyAuthHeader username password)
      describe "oAuth2Token" $ do
        it "sets Authorization header to correct value" $
          property $ \token -> do
            request <- req_ GET url NoReqBody (oAuth2Token token)
            lookup "Authorization" (L.requestHeaders request)
              `shouldBe` pure ("token " <> token)
        it "overwrites manual setting of header" $
          property $ \token value -> do
            request0 <-
              req_
                GET
                url
                NoReqBody
                (oAuth2Token token <> header "Authorization" value)
            request1 <-
              req_
                GET
                url
                NoReqBody
                (header "Authorization" value <> oAuth2Token token)
            let result = "token " <> token
            lookup "Authorization" (L.requestHeaders request0)
              `shouldBe` pure result
            lookup "Authorization" (L.requestHeaders request1)
              `shouldBe` pure result
        it "left auth option wins" $
          property $ \token0 token1 -> do
            request <-
              req_
                GET
                url
                NoReqBody
                (oAuth2Token token0 <> oAuth2Token token1)
            lookup "Authorization" (L.requestHeaders request)
              `shouldBe` pure ("token " <> token0)
      describe "port" $
        it "sets port overwriting the defaults" $
          property $ \n -> do
            request <- req_ GET url NoReqBody (port n)
            L.port request `shouldBe` n
      describe "decompress" $
        it "sets decompress function overwriting the defaults" $
          property $ \token -> do
            request <- req_ GET url NoReqBody (decompress (/= token))
            L.decompress request token `shouldBe` False
      -- FIXME Can't really test responseTimeout right new because the
      -- ResponseTimeout data type does not implement Eq and its constructors
      -- are also not exported. Sent a PR.
      describe "httpVersion" $
        it "sets HTTP version overwriting the defaults" $
          property $ \major minor -> do
            request <- req_ GET url NoReqBody (httpVersion major minor)
            L.requestVersion request `shouldBe` Y.HttpVersion major minor
  
      describe "quasiquoter" $ do
        it "works for valid urls" $
          -- Doing it this way instead of just checking if [urlQ|...|] :: (Url
          -- 'Https, Option _) type checks, so we can catch if the type of scheme
          -- is unspecified.
          let testTypeOfQuoterResult ::
                forall a s. (Typeable a) => (a, Option s) -> Bool
              testTypeOfQuoterResult _ = isJust $ eqT @a @(Url 'Https)
           in property $ testTypeOfQuoterResult [urlQ|https://example.org/|]
        it "doesn't work for invalid urls" $
          property $
            TH.runQ (TH.quoteExp urlQ "not a url") `shouldThrow` anyIOException
  
  ----------------------------------------------------------------------------
  -- Instances
  
  instance MonadHttp IO where
    handleHttpException = throwIO
  
  instance Arbitrary HttpConfig where
    arbitrary = do
      httpConfigProxy <- arbitrary
      httpConfigRedirectCount <- arbitrary
      let httpConfigAltManager = Nothing
          httpConfigCheckResponse _ _ _ = Nothing
          httpConfigRetryPolicy = retryPolicyDefault
          httpConfigRetryJudge _ _ = False
          httpConfigRetryJudgeException _ _ = False
          httpConfigBodyPreviewLength = 1024
      return HttpConfig {..}
  
  instance Show HttpConfig where
    show HttpConfig {..} =
      "HttpConfig\n"
        ++ "{ httpConfigProxy="
        ++ show httpConfigProxy
        ++ "\n"
        ++ ", httpRedirectCount="
        ++ show httpConfigRedirectCount
        ++ "\n"
        ++ ", httpConfigAltManager=<cannot be shown>\n"
        ++ ", httpConfigCheckResponse=<cannot be shown>}\n"
  
  instance Arbitrary L.Proxy where
    arbitrary = L.Proxy <$> arbitrary <*> arbitrary
  
  instance Arbitrary ByteString where
    arbitrary = B.pack <$> arbitrary
  
  instance Arbitrary BL.ByteString where
    arbitrary = BL.pack <$> arbitrary
  
  instance Arbitrary Text where
    arbitrary = T.pack <$> arbitrary
  
  instance Show (Option scheme) where
    show _ = "<cannot be shown>"
  
  data Thing = Thing
    { _thingBool :: Bool,
      _thingText :: Text
    }
    deriving (Eq, Show, Generic)
  
  instance ToJSON Thing
  
  instance Arbitrary Thing where
    arbitrary = Thing <$> arbitrary <*> arbitrary
  
  instance Arbitrary L.CookieJar where
    arbitrary = L.createCookieJar <$> arbitrary
  
  instance Arbitrary L.Cookie where
    arbitrary = do
      cookie_name <- arbitrary
      cookie_value <- arbitrary
      cookie_expiry_time <- arbitrary
      cookie_domain <- arbitrary
      cookie_path <- arbitrary
      cookie_creation_time <- arbitrary
      cookie_last_access_time <- arbitrary
      cookie_persistent <- arbitrary
      cookie_host_only <- arbitrary
      cookie_secure_only <- arbitrary
      cookie_http_only <- arbitrary
      return L.Cookie {..}
  
  instance Arbitrary UTCTime where
    arbitrary = UTCTime <$> arbitrary <*> arbitrary
  
  instance Arbitrary Day where
    arbitrary = ModifiedJulianDay <$> arbitrary
  
  instance Arbitrary DiffTime where
    arbitrary = secondsToDiffTime <$> arbitrary
  
  instance Arbitrary F.Form where
    arbitrary = (F.Form . fromList) <$> arbitrary
  
  ----------------------------------------------------------------------------
  -- Helper types
  
  -- | A wrapper to generate correct hosts.
  newtype Host = Host {unHost :: Text}
    deriving (Eq, Show)
  
  instance Arbitrary Host where
    arbitrary = Host . T.pack <$> listOf1 (arbitrary `suchThat` (/= ':'))
  
  -- | A wrapper to generate correct query parameters.
  newtype QueryParams = QueryParams [(Text, Maybe Text)]
    deriving (Eq, Show)
  
  instance Arbitrary QueryParams where
    arbitrary = QueryParams <$> (arbitrary `suchThat` wellFormed)
      where
        wellFormed = all (not . T.null . fst)
  
  ----------------------------------------------------------------------------
  -- Helpers
  
  -- | 'req' that just returns the prepared 'L.Request'.
  req_ ::
    ( MonadHttp m,
      HttpMethod method,
      HttpBody body,
      HttpBodyAllowed (AllowsBody method) (ProvidesBody body)
    ) =>
    -- | HTTP method
    method ->
    -- | 'Url' — location of resource
    Url scheme ->
    -- | Body of the request
    body ->
    -- | Collection of optional parameters
    Option scheme ->
    -- | Vanilla request
    m L.Request
  req_ method url' body options = req' method url' body options $
    \request _ -> return request
  
  -- | A dummy 'Url'.
  url :: Url 'Https
  url = https "httpbin.org"
  
  -- | Percent encode given 'Text'.
  urlEncode :: Text -> ByteString
  urlEncode = Y.urlEncode False . T.encodeUtf8
  
  -- | Build URL path from given path pieces.
  encodePathPieces :: [Text] -> ByteString
  encodePathPieces = BL.toStrict . BB.toLazyByteString . Y.encodePathSegments
  
  -- | Get host from a 'URI'. This function is not total.
  uriHost :: URI -> ByteString
  uriHost uri =
    fromJust $
      urlEncode . URI.unRText . URI.authHost
        <$> either (const Nothing) Just (URI.uriAuthority uri)
  
  -- | Get part from a 'URI' defaulting to the provided value.
  uriPort :: Int -> URI -> Int
  uriPort def uri =
    maybe def (fromIntegral) $
      either (const Nothing) Just (URI.uriAuthority uri) >>= URI.authPort
  
  -- | Get the path from a 'URI'.
  uriPath :: URI -> ByteString
  uriPath uri = fromMaybe "" $ do
    (trailingSlash, xs) <- URI.uriPath uri
    let pref = (encodePathPieces . fmap URI.unRText . NE.toList) xs
    return $ if trailingSlash then pref <> "/" else pref
  
  -- | Get the query string from a 'URI'.
  uriQuery :: URI -> ByteString
  uriQuery uri = do
    let liftQueryParam = \case
          URI.QueryFlag t -> (URI.unRText t, Nothing)
          URI.QueryParam k v -> (URI.unRText k, Just (URI.unRText v))
    Y.renderQuery True (Y.queryTextToQuery (liftQueryParam <$> (URI.uriQuery uri)))
  
  -- | Predict the headrs that should be set if the given 'URI' has username
  -- and password in it.
  uriBasicAuth :: URI -> Maybe ByteString
  uriBasicAuth uri = do
    auth <- either (const Nothing) Just (URI.uriAuthority uri)
    URI.UserInfo {..} <- URI.authUserInfo auth
    let username = T.encodeUtf8 (URI.unRText uiUsername)
        password = maybe "" (T.encodeUtf8 . URI.unRText) uiPassword
    return (basicAuthHeader username password)
  
  -- | Render a query as lazy 'BL.ByteString'.
  renderQuery :: [(Text, Maybe Text)] -> BL.ByteString
  renderQuery = BL.fromStrict . Y.renderQuery False . Y.queryTextToQuery
  
  -- | Convert collection of query parameters to 'FormUrlEncodedParam' thing.
  formUrlEnc :: [(Text, Maybe Text)] -> FormUrlEncodedParam
  formUrlEnc = foldMap (uncurry queryParam)
  
  -- | Get “Authorization” basic auth header given username and password.
  basicAuthHeader :: ByteString -> ByteString -> ByteString
  basicAuthHeader username password =
    fromJust . lookup Y.hAuthorization . L.requestHeaders $
      L.applyBasicAuth username password L.defaultRequest
  
  -- | Get "Proxy-Authorization" basic proxy auth header given username and
  -- password.
  basicProxyAuthHeader :: ByteString -> ByteString -> ByteString
  basicProxyAuthHeader username password =
    fromJust . lookup Y.hProxyAuthorization . L.requestHeaders $
      L.applyBasicProxyAuth username password L.defaultRequest
  
  -- | Spec about 'paramToList' for the type @p@.
  specParamToList :: (QueryParam p, Monoid p) => Proxy p -> Spec
  specParamToList typeProxy = do
    describe "paramToList" $ do
      it "should reproduce the parameters given by queryParam" $
        property $ \(QueryParams params) -> do
          let queryParam0 =
                (mconcat $ fmap (uncurry queryParam) params)
                  `asProxyTypeOf` typeProxy
              got = queryParamToList queryParam0
          got `shouldBe` params
  