{-# 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 :: forall a. Response a -> Int
statusCode = Status -> Int
HTTP.statusCode (Status -> Int) -> (Response a -> Status) -> Response a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> Status
forall body. Response body -> Status
responseStatus

statusMessage :: Response a -> ByteString
statusMessage :: forall a. Response a -> ByteString
statusMessage = Status -> ByteString
HTTP.statusMessage (Status -> ByteString)
-> (Response a -> Status) -> Response a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> Status
forall body. Response body -> Status
responseStatus

getHeader :: HeaderName -> Response a -> Maybe ByteString
getHeader :: forall a. HeaderName -> Response a -> Maybe ByteString
getHeader HeaderName
h = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
h ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Response a -> [(HeaderName, ByteString)])
-> Response a
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
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' :: forall a. HeaderName -> Response a -> ByteString
getHeader' HeaderName
h = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"NO_HEADER_VALUE" (Maybe ByteString -> ByteString)
-> (Response a -> Maybe ByteString) -> Response a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> Response a -> Maybe ByteString
forall a. HeaderName -> Response a -> Maybe ByteString
getHeader HeaderName
h

getCookie :: ByteString -> Response a -> Maybe Cookie
getCookie :: forall a. ByteString -> Response a -> Maybe Cookie
getCookie ByteString
n Response a
r = (Cookie -> Bool) -> [Cookie] -> Maybe Cookie
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((ByteString
n ==) (ByteString -> Bool) -> (Cookie -> ByteString) -> Cookie -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> ByteString
cookie_name) (CookieJar -> [Cookie]
destroyCookieJar (CookieJar -> [Cookie]) -> CookieJar -> [Cookie]
forall a b. (a -> b) -> a -> b
$ Response a -> CookieJar
forall body. Response body -> CookieJar
responseCookieJar Response a
r)

-- | Retrieve the value of a given cookie name from a "Set-Cookie" header on the response
getCookieValue :: ByteString -> Response a -> Maybe ByteString
getCookieValue :: forall a. ByteString -> Response a -> Maybe ByteString
getCookieValue ByteString
cookieName Response a
resp =
  Response a
resp
    Response a
-> Getting (First ByteString) (Response a) ByteString
-> Maybe ByteString
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Response a -> [(HeaderName, ByteString)])
-> ([(HeaderName, ByteString)]
    -> Const (First ByteString) [(HeaderName, ByteString)])
-> Response a
-> Const (First ByteString) (Response a)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Response a -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders
      (([(HeaderName, ByteString)]
  -> Const (First ByteString) [(HeaderName, ByteString)])
 -> Response a -> Const (First ByteString) (Response a))
-> ((ByteString -> Const (First ByteString) ByteString)
    -> [(HeaderName, ByteString)]
    -> Const (First ByteString) [(HeaderName, ByteString)])
-> Getting (First ByteString) (Response a) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString)
 -> Const (First ByteString) (HeaderName, ByteString))
-> [(HeaderName, ByteString)]
-> Const (First ByteString) [(HeaderName, ByteString)]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
IndexedTraversal
  Int
  [(HeaderName, ByteString)]
  [(HeaderName, ByteString)]
  (HeaderName, ByteString)
  (HeaderName, ByteString)
traversed -- Over each header
      (((HeaderName, ByteString)
  -> Const (First ByteString) (HeaderName, ByteString))
 -> [(HeaderName, ByteString)]
 -> Const (First ByteString) [(HeaderName, ByteString)])
-> ((ByteString -> Const (First ByteString) ByteString)
    -> (HeaderName, ByteString)
    -> Const (First ByteString) (HeaderName, ByteString))
-> (ByteString -> Const (First ByteString) ByteString)
-> [(HeaderName, ByteString)]
-> Const (First ByteString) [(HeaderName, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> Bool)
-> Optic'
     (->)
     (Const (First ByteString))
     (HeaderName, ByteString)
     (HeaderName, ByteString)
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"Set-Cookie") (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) -- Select the cookie headers by name
      Optic'
  (->)
  (Const (First ByteString))
  (HeaderName, ByteString)
  (HeaderName, ByteString)
-> ((ByteString -> Const (First ByteString) ByteString)
    -> (HeaderName, ByteString)
    -> Const (First ByteString) (HeaderName, ByteString))
-> (ByteString -> Const (First ByteString) ByteString)
-> (HeaderName, ByteString)
-> Const (First ByteString) (HeaderName, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const (First ByteString) ByteString)
-> (HeaderName, ByteString)
-> Const (First ByteString) (HeaderName, ByteString)
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (HeaderName, ByteString)
  (HeaderName, ByteString)
  ByteString
  ByteString
_2 -- Select Set-Cookie values
      ((ByteString -> Const (First ByteString) ByteString)
 -> (HeaderName, ByteString)
 -> Const (First ByteString) (HeaderName, ByteString))
-> ((ByteString -> Const (First ByteString) ByteString)
    -> ByteString -> Const (First ByteString) ByteString)
-> (ByteString -> Const (First ByteString) ByteString)
-> (HeaderName, ByteString)
-> Const (First ByteString) (HeaderName, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> SetCookie)
-> (SetCookie -> Const (First ByteString) SetCookie)
-> ByteString
-> Const (First ByteString) ByteString
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ByteString -> SetCookie
parseSetCookie
      ((SetCookie -> Const (First ByteString) SetCookie)
 -> ByteString -> Const (First ByteString) ByteString)
-> ((ByteString -> Const (First ByteString) ByteString)
    -> SetCookie -> Const (First ByteString) SetCookie)
-> (ByteString -> Const (First ByteString) ByteString)
-> ByteString
-> Const (First ByteString) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SetCookie -> Bool)
-> Optic' (->) (Const (First ByteString)) SetCookie SetCookie
forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
cookieName) (ByteString -> Bool)
-> (SetCookie -> ByteString) -> SetCookie -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> ByteString
setCookieName) -- Select only the cookie we want
      Optic' (->) (Const (First ByteString)) SetCookie SetCookie
-> ((ByteString -> Const (First ByteString) ByteString)
    -> SetCookie -> Const (First ByteString) SetCookie)
-> (ByteString -> Const (First ByteString) ByteString)
-> SetCookie
-> Const (First ByteString) SetCookie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SetCookie -> ByteString)
-> (ByteString -> Const (First ByteString) ByteString)
-> SetCookie
-> Const (First ByteString) SetCookie
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SetCookie -> ByteString
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 :: forall a.
(HasCallStack, Typeable a, FromJSON a) =>
ResponseLBS -> Either String a
responseJsonEither = (String -> String) -> Either String a -> Either String a
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL String -> String
addTypeInfo (Either String a -> Either String a)
-> (ByteString -> Either String a) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String a)
-> (ResponseLBS -> Either String ByteString)
-> ResponseLBS
-> Either String a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either String ByteString
-> (ByteString -> Either String ByteString)
-> Maybe ByteString
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either String ByteString
forall void. Either String void
err ByteString -> Either String ByteString
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Either String ByteString)
-> (ResponseLBS -> Maybe ByteString)
-> ResponseLBS
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseLBS -> Maybe ByteString
forall body. Response body -> body
responseBody
  where
    err :: Either String void
    err :: forall void. Either String void
err = String -> Either String void
forall a b. a -> Either a b
Left String
"Missing response body."
    addTypeInfo :: String -> String
    addTypeInfo :: String -> String
addTypeInfo = ((TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Data.Proxy.Proxy @a)) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ") <>)

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

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

{-# INLINE responseJsonError #-}
responseJsonError ::
  (HasCallStack, MonadThrow m, Typeable a, FromJSON a) =>
  ResponseLBS ->
  m a
responseJsonError :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m, Typeable a, FromJSON a) =>
ResponseLBS -> m a
responseJsonError = (String -> ErrorCall) -> ResponseLBS -> m a
forall (m :: * -> *) a e.
(HasCallStack, MonadThrow m, Typeable a, FromJSON a,
 Exception e) =>
(String -> e) -> ResponseLBS -> m a
responseJsonThrow String -> ErrorCall
ErrorCall

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

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

showResponse :: (Show a) => Response a -> String
showResponse :: forall a. Show a => Response a -> String
showResponse Response a
r =
  String -> String -> String
showString String
"HTTP/"
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Show a => a -> String -> String
shows (HttpVersion -> Int
httpMajor (HttpVersion -> Int)
-> (Response a -> HttpVersion) -> Response a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> HttpVersion
forall body. Response body -> HttpVersion
responseVersion (Response a -> Int) -> Response a -> Int
forall a b. (a -> b) -> a -> b
$ Response a
r)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"."
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Show a => a -> String -> String
shows (HttpVersion -> Int
httpMinor (HttpVersion -> Int)
-> (Response a -> HttpVersion) -> Response a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> HttpVersion
forall body. Response body -> HttpVersion
responseVersion (Response a -> Int) -> Response a -> Int
forall a b. (a -> b) -> a -> b
$ Response a
r)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" "
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Show a => a -> String -> String
shows (Response a -> Int
forall a. Response a -> Int
statusCode Response a
r)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
" "
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString (ByteString -> String
C.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Response a -> ByteString
forall a. Response a -> ByteString
statusMessage Response a
r)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"\n"
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
showHeaders
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString String
"\n\n"
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String -> String
forall a. Show a => a -> String -> String
shows (Response a -> a
forall body. Response body -> body
responseBody Response a
r)
    (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
""
  where
    showHeaders :: String -> String
showHeaders = ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (String -> String -> String
showString String
"") (((HeaderName, ByteString) -> String -> String)
-> [(HeaderName, ByteString)] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map (HeaderName, ByteString) -> String -> String
showHdr (Response a -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response a
r))
    showHdr :: (HeaderName, ByteString) -> String -> String
showHdr (HeaderName
k, ByteString
v) = String -> String -> String
showString (String -> String -> String)
-> (ByteString -> String) -> ByteString -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
C.unpack (ByteString -> String -> String) -> ByteString -> String -> String
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
original HeaderName
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"