content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Network.HTTP.ReqSpec (spec) where
  
  import Control.Exception
  import Control.Monad (forM_)
  import Control.Monad.Trans.Control
  import Data.Aeson (ToJSON (..), Value (..), object, (.=))
  import Data.Aeson qualified as A
  import Data.Aeson.KeyMap qualified as Aeson.KeyMap
  import Data.ByteString qualified as B
  import Data.ByteString.Lazy qualified as BL
  import Data.Functor.Identity (runIdentity)
  import Data.Maybe (fromJust)
  import Data.Proxy
  import Data.Text (Text)
  import Data.Text qualified as T
  import Data.Text.Encoding qualified as T
  import Data.Text.IO qualified as TIO
  import Network.HTTP.Client qualified as L
  import Network.HTTP.Client.MultipartFormData qualified as LM
  import Network.HTTP.Req hiding (req)
  import Network.HTTP.Req qualified as Req
  import Network.HTTP.Types qualified as Y
  import Test.Hspec
  import Test.QuickCheck
  
  spec :: Spec
  spec = do
    describe "exception throwing on non-2xx status codes" $
      it "throws indeed for non-2xx" $
        req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
          `shouldThrow` selector404
  
    describe "exception throwing on non-2xx status codes (Req monad)" $
      it "throws indeed for non-2xx" $
        asIO . runReq defaultHttpConfig $
          liftBaseWith $ \run ->
            run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty)
              `shouldThrow` selector404
  
    describe "response check via httpConfigCheckResponse" $
      context "if it's set to always throw" $
        it "throws indeed" $
          blindlyThrowing (req GET httpbin NoReqBody ignoreResponse mempty)
            `shouldThrow` anyException
  
    describe "isStatusCodeException" $
      it "extracts non-2xx response" $
        req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty
          `shouldThrow` selector404ByStatusCodeException
  
    describe "receiving user-agent header back" $
      it "works" $ do
        r <-
          req
            GET
            (httpbin /: "user-agent")
            NoReqBody
            jsonResponse
            (header "user-agent" "Req")
        responseBody r
          `shouldBe` object
            ["user-agent" .= ("Req" :: Text)]
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    describe "receiving request headers back" $
      it "works" $ do
        r <-
          req
            GET
            (httpbin /: "headers")
            NoReqBody
            jsonResponse
            (header "Foo" "bar" <> header "Baz" "quux")
        stripFunnyHeaders (responseBody r)
          `shouldBe` object
            [ "headers"
                .= object
                  [ "Accept-Encoding" .= ("gzip" :: Text),
                    "Foo" .= ("bar" :: Text),
                    "Baz" .= ("quux" :: Text)
                  ]
            ]
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    describe "receiving GET data back" $
      it "works" $ do
        r <- req GET (httpbin /: "get") NoReqBody jsonResponse mempty
        (stripFunnyHeaders . stripOrigin) (responseBody r)
          `shouldBe` object
            [ "args" .= emptyObject,
              "url" .= ("http://localhost:1234/get" :: Text),
              "headers"
                .= object
                  [ "Accept-Encoding" .= ("gzip" :: Text)
                  ]
            ]
        responseHeader r "Content-Type" `shouldBe` return "application/json"
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    describe "receiving POST JSON data back" $
      it "works" $ do
        let text = "foo" :: Text
            reflected = reflectJSON text
        r <- req POST (httpbin /: "post") (ReqBodyJson text) jsonResponse mempty
        (stripFunnyHeaders . stripOrigin) (responseBody r)
          `shouldBe` object
            [ "args" .= emptyObject,
              "json" .= text,
              "data" .= reflected,
              "url" .= ("http://localhost:1234/post" :: Text),
              "headers"
                .= object
                  [ "Content-Type" .= ("application/json; charset=utf-8" :: Text),
                    "Accept-Encoding" .= ("gzip" :: Text),
                    "Content-Length" .= show (T.length reflected)
                  ],
              "files" .= emptyObject,
              "form" .= emptyObject
            ]
        responseHeader r "Content-Type" `shouldBe` return "application/json"
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    describe "receiving POST data back (multipart form data)" $
      it "works" $ do
        body <-
          reqBodyMultipart
            [ LM.partBS "foo" "foo data!",
              LM.partBS "bar" "bar data!"
            ]
        r <- req POST (httpbin /: "post") body jsonResponse mempty
        let contentType = fromJust (getRequestContentType body)
        (stripFunnyHeaders . stripOrigin) (responseBody r)
          `shouldBe` object
            [ "args" .= emptyObject,
              "json" .= Null,
              "data" .= ("" :: Text),
              "url" .= ("http://localhost:1234/post" :: Text),
              "headers"
                .= object
                  [ "Content-Type" .= T.decodeUtf8 contentType,
                    "Accept-Encoding" .= ("gzip" :: Text),
                    "Content-Length" .= ("242" :: Text)
                  ],
              "files" .= emptyObject,
              "form"
                .= object
                  [ "foo" .= ("foo data!" :: Text),
                    "bar" .= ("bar data!" :: Text)
                  ]
            ]
        responseHeader r "Content-Type" `shouldBe` return "application/json"
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    describe "receiving PATCHed file back" $
      it "works" $ do
        let file :: FilePath
            file = "httpbin-data/robots.txt"
        contents <- TIO.readFile file
        r <- req PATCH (httpbin /: "patch") (ReqBodyFile file) jsonResponse mempty
        (stripFunnyHeaders . stripOrigin) (responseBody r)
          `shouldBe` object
            [ "args" .= emptyObject,
              "json" .= Null,
              "data" .= contents,
              "url" .= ("http://localhost:1234/patch" :: Text),
              "headers"
                .= object
                  [ "Accept-Encoding" .= ("gzip" :: Text),
                    "Content-Length" .= show (T.length contents)
                  ],
              "files" .= emptyObject,
              "form" .= emptyObject
            ]
        responseHeader r "Content-Type" `shouldBe` return "application/json"
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    describe "receiving PUT form URL-encoded data back" $
      it "works" $ do
        let params =
              "foo" =: ("bar" :: Text)
                <> "baz" =: (5 :: Int)
                <> queryFlag "quux"
        r <- req PUT (httpbin /: "put") (ReqBodyUrlEnc params) jsonResponse mempty
        (stripFunnyHeaders . stripOrigin) (responseBody r)
          `shouldBe` object
            [ "args" .= emptyObject,
              "json" .= Null,
              "data" .= ("" :: Text),
              "url" .= ("http://localhost:1234/put" :: Text),
              "headers"
                .= object
                  [ "Content-Type" .= ("application/x-www-form-urlencoded" :: Text),
                    "Accept-Encoding" .= ("gzip" :: Text),
                    "Content-Length" .= ("18" :: Text)
                  ],
              "files" .= emptyObject,
              "form"
                .= object
                  [ "foo" .= ("bar" :: Text),
                    "baz" .= ("5" :: Text),
                    "quux" .= ("" :: Text)
                  ]
            ]
        responseHeader r "Content-Type" `shouldBe` return "application/json"
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    -- TODO /delete
  
    describe "receiving UTF-8 encoded Unicode data" $
      it "works" $ do
        r <-
          req
            GET
            (httpbin /: "encoding" /: "utf8")
            NoReqBody
            bsResponse
            mempty
        utf8data <- B.readFile "httpbin-data/utf8.html"
        responseBody r `shouldBe` utf8data
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    -- TODO /gzip
    -- TODO /deflate
  
    describe "retrying" $
      it "retries as many times as specified" $ do
        -- FIXME We no longer can count retries because all the functions
        -- responsible for controlling retrying are pure now.
        let status = 408 :: Int
        r <-
          prepareForShit $
            req
              GET
              (httpbin /: "status" /~ status)
              NoReqBody
              ignoreResponse
              mempty
        responseStatusCode r `shouldBe` status
  
    -- forM_ [101..102] checkStatusCode
    forM_ [200 .. 208] checkStatusCode
    -- forM_ [300..308] checkStatusCode
    forM_ [400 .. 431] checkStatusCode
    forM_ [500 .. 511] checkStatusCode
  
    -- TODO /response-headers
    -- TODO /redirect
  
    describe "redirects" $
      it "follows redirects" $ do
        r <-
          req
            GET
            (httpbin /: "redirect-to")
            NoReqBody
            ignoreResponse
            ("url" =: ("https://httpbin.org" :: Text))
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    -- TODO /relative-redicet
    -- TODO /absolute-redirect
    -- TODO /cookies
  
    describe "basicAuth" $ do
      let user, password :: Text
          user = "Scooby"
          password = "Doo"
      context "when we do not send appropriate basic auth data" $
        it "fails with 401" $ do
          r <-
            prepareForShit $
              req
                GET
                (httpbin /: "basic-auth" /~ user /~ password)
                NoReqBody
                ignoreResponse
                mempty
          responseStatusCode r `shouldBe` 401
          responseStatusMessage r `shouldBe` "UNAUTHORIZED"
      context "when we provide appropriate basic auth data" $
        it "succeeds" $ do
          r <-
            req
              GET
              (httpbin /: "basic-auth" /~ user /~ password)
              NoReqBody
              ignoreResponse
              (basicAuthUnsafe (T.encodeUtf8 user) (T.encodeUtf8 password))
          responseStatusCode r `shouldBe` 200
          responseStatusMessage r `shouldBe` "OK"
  
    -- TODO /hidden-basic-auth
    -- TODO /digest-auth
    -- TODO /stream
    -- TODO /delay
    -- TODO /drip
    -- TODO /range
    -- TODO /html
  
    describe "robots.txt" $
      it "works" $ do
        r <- req GET (httpbin /: "robots.txt") NoReqBody bsResponse mempty
        robots <- B.readFile "httpbin-data/robots.txt"
        responseBody r `shouldBe` robots
        responseStatusCode r `shouldBe` 200
        responseStatusMessage r `shouldBe` "OK"
  
    -- TODO /deny
    -- TODO /cache
  
    describe "getting random bytes" $ do
      it "works" $
        property $ \n' -> do
          let n :: Word
              n = getSmall n'
          r <-
            req
              GET
              (httpbin /: "bytes" /~ n)
              NoReqBody
              lbsResponse
              mempty
          responseBody r `shouldSatisfy` ((== n) . fromIntegral . BL.length)
          responseStatusCode r `shouldBe` 200
          responseStatusMessage r `shouldBe` "OK"
      context "when we try to interpret 1000 random bytes as JSON" $
        it "throws correct exception" $ do
          let selector :: HttpException -> Bool
              selector (JsonHttpException _) = True
              selector _ = False
              n :: Int
              n = 1000
          req
            GET
            (httpbin /: "bytes" /~ n)
            NoReqBody
            (Proxy :: Proxy (JsonResponse Value))
            mempty
            `shouldThrow` selector
  
    describe "streaming random bytes" $
      it "works" $
        property $ \n' -> do
          let n :: Word
              n = getSmall n'
          r <-
            req
              GET
              (httpbin /: "stream-bytes" /~ n)
              NoReqBody
              bsResponse
              mempty
          responseBody r `shouldSatisfy` ((== n) . fromIntegral . B.length)
          responseStatusCode r `shouldBe` 200
          responseStatusMessage r `shouldBe` "OK"
  
  -- TODO /links
  -- TODO /image
  -- TODO /image/png
  -- TODO /image/jpeg
  -- TODO /image/webp
  -- TODO /image/svg
  -- TODO /forms/post
  -- TODO /xml
  
  ----------------------------------------------------------------------------
  -- Instances
  
  instance MonadHttp IO where
    handleHttpException = throwIO
  
  ----------------------------------------------------------------------------
  -- Helpers
  
  -- | Run a request with such settings that it does not signal errors.
  prepareForShit :: Req a -> IO a
  prepareForShit = runReq defaultHttpConfig {httpConfigCheckResponse = noNoise}
    where
      noNoise _ _ _ = Nothing
  
  -- | Run a request with such settings that it throws on any response.
  blindlyThrowing :: Req a -> IO a
  blindlyThrowing = runReq defaultHttpConfig {httpConfigCheckResponse = doit}
    where
      doit _ _ = error "Oops!"
  
  -- | 'Url' representing <https://httpbin.org>.
  httpbin :: Url 'Http
  httpbin = http "localhost"
  
  req ::
    ( MonadHttp m,
      HttpMethod method,
      HttpBody body,
      HttpResponse response,
      HttpBodyAllowed (AllowsBody method) (ProvidesBody body)
    ) =>
    method ->
    Url scheme ->
    body ->
    Proxy response ->
    Option scheme ->
    m response
  req method url body responseProxy options =
    Req.req method url body responseProxy (options <> defaultOptions)
  
  -- | Options to apply by default.
  defaultOptions :: Option scheme
  defaultOptions = port 1234
  
  -- | Remove “origin” field from JSON value. Origin may change, we don't want
  -- to depend on that.
  stripOrigin :: Value -> Value
  stripOrigin (Object m) = Object (Aeson.KeyMap.delete "origin" m)
  stripOrigin value = value
  
  -- | Remove funny headers that might break the tests.
  stripFunnyHeaders :: Value -> Value
  stripFunnyHeaders = \case
    Object m ->
      Object
        ( runIdentity
            ( Aeson.KeyMap.alterF
                (pure . fmap stripFunnyHeaders')
                "headers"
                m
            )
        )
    value -> value
  
  -- | Similar to 'stripFunnyHeaders', but acts directly on the argument
  -- without trying to access its "headers" field.
  stripFunnyHeaders' :: Value -> Value
  stripFunnyHeaders' = \case
    Object p ->
      Object $
        Aeson.KeyMap.filterWithKey
          (\k _ -> k `elem` whitelistedHeaders)
          p
    value -> value
    where
      whitelistedHeaders =
        [ "Content-Type",
          "Accept-Encoding",
          "Content-Length",
          "Foo",
          "Baz"
        ]
  
  -- | This is a complete test case that makes use of <https://httpbin.org> to
  -- get various response status codes.
  checkStatusCode :: Int -> SpecWith ()
  checkStatusCode code =
    describe ("receiving status code " ++ show code) $
      it "works" $ do
        r <-
          prepareForShit $
            req
              GET
              (httpbin /: "status" /~ code)
              NoReqBody
              ignoreResponse
              mempty
        responseStatusCode r `shouldBe` code
  
  -- | Exception selector that selects only 404 “Not found” exceptions.
  selector404 :: HttpException -> Bool
  selector404
    ( VanillaHttpException
        ( L.HttpExceptionRequest
            _
            (L.StatusCodeException response chunk)
          )
      ) =
      L.responseStatus response == Y.status404 && not (B.null chunk)
  selector404 _ = False
  
  -- | Same as 'selector404' except that it uses 'isStatusCodeException'.
  selector404ByStatusCodeException :: HttpException -> Bool
  selector404ByStatusCodeException e =
    case isStatusCodeException e of
      Nothing -> False
      Just r -> responseStatusCode r == 404
  
  -- | The empty JSON 'Object'.
  emptyObject :: Value
  emptyObject = Object Aeson.KeyMap.empty
  
  -- | Get a rendered JSON value as 'Text'.
  reflectJSON :: (ToJSON a) => a -> Text
  reflectJSON = T.decodeUtf8 . BL.toStrict . A.encode
  
  -- | Clarify to the type checker that the inner computation is in the 'IO'
  -- monad.
  asIO :: IO a -> IO a
  asIO = id
  