{-# LANGUAGE OverloadedStrings #-}
-- Disabling due to HasCallStack
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Bilge.Response
  ( -- * Helpers
    statusCode,
    statusMessage,
    getHeader,
    getHeader',
    getCookie,
    getCookieValue,
    showResponse,

    -- * Re-exports
    Response,
    ResponseLBS,
    responseStatus,
    responseHeaders,
    responseVersion,
    responseBody,
    responseJsonEither,
    responseJsonMaybe,
    responseJsonThrow,
    responseJsonError,
    responseJsonUnsafe,
    responseJsonUnsafeWithMsg,
  )
where

import Control.Exception (ErrorCall (ErrorCall))
import Control.Lens
import Control.Monad.Catch
import Data.Aeson (FromJSON, eitherDecode)
import Data.ByteString.Char8 qualified as C
import Data.CaseInsensitive (original)
import Data.EitherR (fmapL)
import Data.Proxy qualified
import Data.Typeable (typeRep)
import Imports
import Network.HTTP.Client
import Network.HTTP.Types (HeaderName, httpMajor, httpMinor)
import Network.HTTP.Types qualified as HTTP
import Web.Cookie

statusCode :: Response a -> Int
statusCode = HTTP.statusCode . responseStatus

statusMessage :: Response a -> ByteString
statusMessage = HTTP.statusMessage . responseStatus

getHeader :: HeaderName -> Response a -> Maybe ByteString
getHeader h = lookup h . responseHeaders

-- | Like 'getHeader', but if no value exists for the given key, return the
-- static ByteString \"NO_HEADER_VALUE\".
getHeader' :: HeaderName -> Response a -> ByteString
getHeader' h = fromMaybe "NO_HEADER_VALUE" . getHeader h

getCookie :: ByteString -> Response a -> Maybe Cookie
getCookie n r = find ((n ==) . cookie_name) (destroyCookieJar $ responseCookieJar r)

-- | Retrieve the value of a given cookie name from a "Set-Cookie" header on the response
getCookieValue :: ByteString -> Response a -> Maybe ByteString
getCookieValue cookieName resp =
  resp
    ^? to responseHeaders
      . traversed -- Over each header
      . filtered ((== "Set-Cookie") . fst) -- Select the cookie headers by name
      . _2 -- Select Set-Cookie values
      . to parseSetCookie
      . filtered ((== cookieName) . setCookieName) -- Select only the cookie we want
      . to setCookieValue -- extract the cookie value

type ResponseLBS = Response (Maybe LByteString)

{-# INLINE responseJsonEither #-}
responseJsonEither ::
  forall a.
  (HasCallStack, Typeable a, FromJSON a) =>
  ResponseLBS ->
  Either String a
responseJsonEither = fmapL addTypeInfo . eitherDecode <=< maybe err pure . responseBody
  where
    err :: Either String void
    err = Left "Missing response body."
    addTypeInfo :: String -> String
    addTypeInfo = ((show (typeRep (Data.Proxy.Proxy @a)) <> " ") <>)

{-# INLINE responseJsonMaybe #-}
responseJsonMaybe ::
  (HasCallStack, Typeable a, FromJSON a) =>
  ResponseLBS ->
  Maybe a
responseJsonMaybe = either (const Nothing) Just . responseJsonEither

{-# INLINE responseJsonThrow #-}
responseJsonThrow ::
  (HasCallStack, MonadThrow m, Typeable a, FromJSON a, Exception e) =>
  (String -> e) ->
  ResponseLBS ->
  m a
responseJsonThrow mkErr = either (throwM . mkErr) pure . responseJsonEither

{-# INLINE responseJsonError #-}
responseJsonError ::
  (HasCallStack, MonadThrow m, Typeable a, FromJSON a) =>
  ResponseLBS ->
  m a
responseJsonError = responseJsonThrow ErrorCall

{-# INLINE responseJsonUnsafe #-}
responseJsonUnsafe ::
  (HasCallStack, Typeable a, FromJSON a) =>
  ResponseLBS ->
  a
responseJsonUnsafe resp = responseJsonUnsafeWithMsg (show resp) resp

{-# INLINE responseJsonUnsafeWithMsg #-}
responseJsonUnsafeWithMsg ::
  (HasCallStack, Typeable a, FromJSON a) =>
  String ->
  ResponseLBS ->
  a
responseJsonUnsafeWithMsg userErr = either err id . responseJsonEither
  where
    err parserErr =
      error . unwords $
        ["responseJsonUnsafeWithMsg:"]
          <> [userErr | not $ null userErr]
          <> [parserErr]

showResponse :: (Show a) => Response a -> String
showResponse r =
  showString "HTTP/"
    . shows (httpMajor . responseVersion $ r)
    . showString "."
    . shows (httpMinor . responseVersion $ r)
    . showString " "
    . shows (statusCode r)
    . showString " "
    . showString (C.unpack $ statusMessage r)
    . showString "\n"
    . showHeaders
    . showString "\n\n"
    . shows (responseBody r)
    $ ""
  where
    showHeaders = foldl' (.) (showString "") (map showHdr (responseHeaders r))
    showHdr (k, v) = showString . C.unpack $ original k <> ": " <> v <> "\n"
