{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Bilge.Response
(
statusCode,
statusMessage,
getHeader,
getHeader',
getCookie,
getCookieValue,
showResponse,
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
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
getHeader' :: HeaderName -> Response a -> ByteString
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)
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
(((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)
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
((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)
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
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"