module Testlib.HTTP where

import qualified Control.Exception as E
import Control.Monad.Reader
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Data.Bifunctor (Bifunctor (bimap))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import Data.Function
import Data.List
import Data.List.Split (splitOn)
import qualified Data.Map as Map
import Data.Maybe
import Data.String
import Data.String.Conversions (cs)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Tuple.Extra
import GHC.Generics
import GHC.Stack
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Types (hLocation)
import qualified Network.HTTP.Types as HTTP
import Network.HTTP.Types.URI (parseQuery)
import Network.URI (URI (..), URIAuth (..), parseURI)
import Testlib.Assertions
import Testlib.Env
import Testlib.JSON
import Testlib.Types
import Web.Cookie
import Prelude

splitHttpPath :: String -> [String]
splitHttpPath :: String -> [String]
splitHttpPath String
path = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"/" String
path)

joinHttpPath :: [String] -> String
joinHttpPath :: [String] -> String
joinHttpPath = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/"

addJSONObject :: [Aeson.Pair] -> HTTP.Request -> HTTP.Request
addJSONObject :: [Pair] -> Request -> Request
addJSONObject = Value -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
addJSON (Value -> Request -> Request)
-> ([Pair] -> Value) -> [Pair] -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
Aeson.object

addJSON :: (Aeson.ToJSON a) => a -> HTTP.Request -> HTTP.Request
addJSON :: forall a. ToJSON a => a -> Request -> Request
addJSON a
obj = RequestBody -> String -> Request -> Request
addBody (ByteString -> RequestBody
HTTP.RequestBodyLBS (a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode a
obj)) String
"application/json"

addXML :: ByteString -> HTTP.Request -> HTTP.Request
addXML :: ByteString -> Request -> Request
addXML ByteString
xml = RequestBody -> String -> Request -> Request
addBody (ByteString -> RequestBody
HTTP.RequestBodyBS ByteString
xml) String
"application/xml"

addUrlEncodedForm :: [(String, String)] -> HTTP.Request -> HTTP.Request
addUrlEncodedForm :: [(String, String)] -> Request -> Request
addUrlEncodedForm [(String, String)]
form Request
req =
  Request
req
    { HTTP.requestBody = HTTP.RequestBodyLBS (L.fromStrict (HTTP.renderSimpleQuery False (both C8.pack <$> form))),
      HTTP.requestHeaders =
        (fromString "Content-Type", fromString "application/x-www-form-urlencoded")
          : HTTP.requestHeaders req
    }

addBody :: HTTP.RequestBody -> String -> HTTP.Request -> HTTP.Request
addBody :: RequestBody -> String -> Request -> Request
addBody RequestBody
body String
contentType Request
req =
  Request
req
    { HTTP.requestBody = body,
      HTTP.requestHeaders =
        (fromString "Content-Type", fromString contentType)
          : HTTP.requestHeaders req
    }

addMLS :: ByteString -> HTTP.Request -> HTTP.Request
addMLS :: ByteString -> Request -> Request
addMLS ByteString
bytes Request
req =
  Request
req
    { HTTP.requestBody = HTTP.RequestBodyBS bytes,
      HTTP.requestHeaders =
        (fromString "Content-Type", fromString "message/mls")
          : HTTP.requestHeaders req
    }

addProtobuf :: ByteString -> HTTP.Request -> HTTP.Request
addProtobuf :: ByteString -> Request -> Request
addProtobuf ByteString
bytes Request
req =
  Request
req
    { HTTP.requestBody = HTTP.RequestBodyBS bytes,
      HTTP.requestHeaders = (fromString "Content-Type", fromString "application/x-protobuf") : HTTP.requestHeaders req
    }

addHeader :: String -> String -> HTTP.Request -> HTTP.Request
addHeader :: String -> String -> Request -> Request
addHeader String
name String
value Request
req =
  Request
req {HTTP.requestHeaders = (CI.mk . C8.pack $ name, C8.pack value) : HTTP.requestHeaders req}

setCookie :: String -> HTTP.Request -> HTTP.Request
setCookie :: String -> Request -> Request
setCookie String
c Request
r =
  String -> String -> Request -> Request
addHeader String
"Cookie" (String -> String
forall a b. ConvertibleStrings a b => a -> b
cs String
c) Request
r

getCookie :: String -> Response -> Maybe String
getCookie :: String -> Response -> Maybe String
getCookie String
name Response
resp = do
  ByteString
cookieHeader <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"set-cookie") Response
resp.headers
  ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> SimpleQuery -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
name) (ByteString -> SimpleQuery
parseCookies ByteString
cookieHeader)

addQueryParams :: [(String, String)] -> HTTP.Request -> HTTP.Request
addQueryParams :: [(String, String)] -> Request -> Request
addQueryParams [(String, String)]
params Request
req =
  [(ByteString, Maybe ByteString)] -> Request -> Request
HTTP.setQueryString (((String, String) -> (ByteString, Maybe ByteString))
-> [(String, String)] -> [(ByteString, Maybe ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
k, String
v) -> (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
k, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
v))) [(String, String)]
params) Request
req

contentTypeMixed :: HTTP.Request -> HTTP.Request
contentTypeMixed :: Request -> Request
contentTypeMixed = String -> String -> Request -> Request
addHeader String
"Content-Type" String
"multipart/mixed"

bindResponse :: (HasCallStack) => App Response -> (Response -> App a) -> App a
bindResponse :: forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse App Response
m Response -> App a
k = App Response
m App Response -> (Response -> App a) -> App a
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Response
r -> Response -> (Response -> App a) -> App a
forall a. HasCallStack => Response -> (Response -> App a) -> App a
withResponse Response
r Response -> App a
k

infixl 1 `bindResponse`

withResponse :: (HasCallStack) => Response -> (Response -> App a) -> App a
withResponse :: forall a. HasCallStack => Response -> (Response -> App a) -> App a
withResponse Response
r Response -> App a
k = Response -> App a -> App a
forall a. HasCallStack => Response -> App a -> App a
onFailureAddResponse Response
r (Response -> App a
k Response
r)

-- | Check response status code, then return body.
getBody :: (HasCallStack) => Int -> Response -> App ByteString
getBody :: HasCallStack => Int -> Response -> App ByteString
getBody Int
status = (Response -> (Response -> App ByteString) -> App ByteString)
-> (Response -> App ByteString) -> Response -> App ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip Response -> (Response -> App ByteString) -> App ByteString
forall a. HasCallStack => Response -> (Response -> App a) -> App a
withResponse \Response
resp -> do
  Response
resp.status Int -> Int -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Int
status
  ByteString -> App ByteString
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
resp.body

-- | Check response status code, then return JSON body.
getJSON :: (HasCallStack) => Int -> Response -> App Aeson.Value
getJSON :: HasCallStack => Int -> Response -> App Value
getJSON Int
status = (Response -> (Response -> App Value) -> App Value)
-> (Response -> App Value) -> Response -> App Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip Response -> (Response -> App Value) -> App Value
forall a. HasCallStack => Response -> (Response -> App a) -> App a
withResponse \Response
resp -> do
  Response
resp.status Int -> Int -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Int
status
  Response
resp.json

-- | assert a response code in the 2** range
assertSuccess :: (HasCallStack) => Response -> App ()
assertSuccess :: HasCallStack => Response -> App ()
assertSuccess = (Response -> (Response -> App ()) -> App ())
-> (Response -> App ()) -> Response -> App ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Response -> (Response -> App ()) -> App ()
forall a. HasCallStack => Response -> (Response -> App a) -> App a
withResponse \Response
resp -> Response
resp.status Int -> (Int, Int) -> App ()
forall a. (MakesValue a, HasCallStack) => a -> (Int, Int) -> App ()
`shouldMatchRange` (Int
200, Int
299)

-- | assert a response status code
assertStatus :: (HasCallStack) => Int -> Response -> App ()
assertStatus :: HasCallStack => Int -> Response -> App ()
assertStatus Int
status = (Response -> (Response -> App ()) -> App ())
-> (Response -> App ()) -> Response -> App ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Response -> (Response -> App ()) -> App ()
forall a. HasCallStack => Response -> (Response -> App a) -> App a
withResponse \Response
resp -> Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
status

-- | assert a failure with some failure code and label
assertLabel :: (HasCallStack) => Int -> String -> Response -> App ()
assertLabel :: HasCallStack => Int -> String -> Response -> App ()
assertLabel Int
status String
label Response
resp = do
  Value
j <- HasCallStack => Int -> Response -> App Value
Int -> Response -> App Value
getJSON Int
status Response
resp
  Value
j Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"label" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` String
label

onFailureAddResponse :: (HasCallStack) => Response -> App a -> App a
onFailureAddResponse :: forall a. HasCallStack => Response -> App a -> App a
onFailureAddResponse Response
r App a
m = ReaderT Env IO a -> App a
forall a. ReaderT Env IO a -> App a
App (ReaderT Env IO a -> App a) -> ReaderT Env IO a -> App a
forall a b. (a -> b) -> a -> b
$ do
  Env
e <- ReaderT Env IO Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO a -> ReaderT Env IO a
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT Env IO a) -> IO a -> ReaderT Env IO a
forall a b. (a -> b) -> a -> b
$ IO a -> (AssertionFailure -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Env -> App a -> IO a
forall a. Env -> App a -> IO a
runAppWithEnv Env
e App a
m) ((AssertionFailure -> IO a) -> IO a)
-> (AssertionFailure -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(AssertionFailure CallStack
stack Maybe Response
_ Maybe String
ctx String
msg) -> do
    AssertionFailure -> IO a
forall a e. Exception e => e -> a
E.throw (CallStack
-> Maybe Response -> Maybe String -> String -> AssertionFailure
AssertionFailure CallStack
stack (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
r) Maybe String
ctx String
msg)

data Versioned = Versioned | Unversioned | ExplicitVersion Int
  deriving stock ((forall x. Versioned -> Rep Versioned x)
-> (forall x. Rep Versioned x -> Versioned) -> Generic Versioned
forall x. Rep Versioned x -> Versioned
forall x. Versioned -> Rep Versioned x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Versioned -> Rep Versioned x
from :: forall x. Versioned -> Rep Versioned x
$cto :: forall x. Rep Versioned x -> Versioned
to :: forall x. Rep Versioned x -> Versioned
Generic)

-- | If you don't know what domain is for or what you should put in there, try `rawBaseRequest
-- OwnDomain ...`.
rawBaseRequest :: (HasCallStack, MakesValue domain) => domain -> Service -> Versioned -> String -> App HTTP.Request
rawBaseRequest :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Service -> Versioned -> String -> App Request
rawBaseRequest domain
domain Service
service Versioned
versioned String
path = do
  String
domainV <- domain -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objDomain domain
domain

  [String]
pathSegsPrefix <- case Versioned
versioned of
    Versioned
Versioned -> do
      Int
v <- String -> App Int
forall domain. MakesValue domain => domain -> App Int
getAPIVersionFor String
domainV
      [String] -> App [String]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
v]
    Versioned
Unversioned -> [String] -> App [String]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    ExplicitVersion Int
v -> do
      [String] -> App [String]
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
v]

  ServiceMap
serviceMap <- HasCallStack => String -> App ServiceMap
String -> App ServiceMap
getServiceMap String
domainV

  IO Request -> App Request
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> App Request)
-> (String -> IO Request) -> String -> App Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseRequest (String -> App Request) -> String -> App Request
forall a b. (a -> b) -> a -> b
$
    let HostPort String
h Word16
p = ServiceMap -> Service -> HostPort
serviceHostPort ServiceMap
serviceMap Service
service
     in String
"http://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
h String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show Word16
p String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
joinHttpPath ([String]
pathSegsPrefix [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> String -> [String]
splitHttpPath String
path))

getAPIVersionFor :: (MakesValue domain) => domain -> App Int
getAPIVersionFor :: forall domain. MakesValue domain => domain -> App Int
getAPIVersionFor domain
domain = do
  String
d <- domain -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString domain
domain
  Map String Int
versionMap <- (Env -> Map String Int) -> App (Map String Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.apiVersionByDomain)
  case String -> Map String Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
d Map String Int
versionMap of
    Maybe Int
Nothing -> (Env -> Int) -> App Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.defaultAPIVersion)
    Just Int
v -> Int -> App Int
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
v

baseRequest :: (HasCallStack, MakesValue user) => user -> Service -> Versioned -> String -> App HTTP.Request
baseRequest :: forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Service -> Versioned -> String -> App Request
baseRequest user
user Service
service Versioned
versioned String
path = do
  Request
req <- user -> Service -> Versioned -> String -> App Request
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Service -> Versioned -> String -> App Request
rawBaseRequest user
user Service
service Versioned
versioned String
path
  String
uid <- user -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
objId user
user
  Maybe String
cli <-
    user -> App Value
forall a. (MakesValue a, HasCallStack) => a -> App Value
make user
user App Value -> (Value -> App (Maybe String)) -> App (Maybe String)
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Aeson.Object Object
_ -> do
        Maybe Value
c <- user -> String -> App (Maybe Value)
forall a.
(HasCallStack, MakesValue a) =>
a -> String -> App (Maybe Value)
lookupField user
user String
"client_id"
        (Value -> App String) -> Maybe Value -> App (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString Maybe Value
c
      Value
_ -> Maybe String -> App (Maybe String)
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
  Request -> App Request
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> App Request) -> Request -> App Request
forall a b. (a -> b) -> a -> b
$ Request
req Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& String -> Request -> Request
zUser String
uid Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& (Request -> Request)
-> (String -> Request -> Request)
-> Maybe String
-> Request
-> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id String -> Request -> Request
zClient Maybe String
cli Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& String -> Request -> Request
zConnection String
"conn"

zUser :: String -> HTTP.Request -> HTTP.Request
zUser :: String -> Request -> Request
zUser = String -> String -> Request -> Request
addHeader String
"Z-User"

zProvider :: String -> HTTP.Request -> HTTP.Request
zProvider :: String -> Request -> Request
zProvider = String -> String -> Request -> Request
addHeader String
"Z-Provider"

zConnection :: String -> HTTP.Request -> HTTP.Request
zConnection :: String -> Request -> Request
zConnection = String -> String -> Request -> Request
addHeader String
"Z-Connection"

zClient :: String -> HTTP.Request -> HTTP.Request
zClient :: String -> Request -> Request
zClient = String -> String -> Request -> Request
addHeader String
"Z-Client"

zType :: String -> HTTP.Request -> HTTP.Request
zType :: String -> Request -> Request
zType = String -> String -> Request -> Request
addHeader String
"Z-Type"

zHost :: String -> HTTP.Request -> HTTP.Request
zHost :: String -> Request -> Request
zHost = String -> String -> Request -> Request
addHeader String
"Z-Host"

submit :: String -> HTTP.Request -> App Response
submit :: String -> Request -> App Response
submit String
method Request
req0 = do
  let req :: Request
req = Request
req0 {HTTP.method = T.encodeUtf8 (T.pack method)}
  Manager
manager <- (Env -> Manager) -> App Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.manager)
  Response ByteString
res <- IO (Response ByteString) -> App (Response ByteString)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> App (Response ByteString))
-> IO (Response ByteString) -> App (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
manager
  Response -> App Response
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> App Response) -> Response -> App Response
forall a b. (a -> b) -> a -> b
$
    Response
      { $sel:jsonBody:Response :: Maybe Value
jsonBody = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
res),
        $sel:body:Response :: ByteString
body = ByteString -> ByteString
L.toStrict (Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
res),
        $sel:status:Response :: Int
status = Status -> Int
HTTP.statusCode (Response ByteString -> Status
forall body. Response body -> Status
HTTP.responseStatus Response ByteString
res),
        $sel:headers:Response :: [(HeaderName, ByteString)]
headers = Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
HTTP.responseHeaders Response ByteString
res,
        $sel:request:Response :: Request
request = Request
req
      }

locationHeaderHost :: Response -> String
locationHeaderHost :: Response -> String
locationHeaderHost Response
resp =
  let location :: String
location = ByteString -> String
C8.unpack (ByteString -> String)
-> (Maybe (HeaderName, ByteString) -> ByteString)
-> Maybe (HeaderName, ByteString)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((HeaderName, ByteString) -> ByteString)
-> (Maybe (HeaderName, ByteString) -> (HeaderName, ByteString))
-> Maybe (HeaderName, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (HeaderName, ByteString) -> (HeaderName, ByteString)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (HeaderName, ByteString) -> String)
-> Maybe (HeaderName, ByteString) -> String
forall a b. (a -> b) -> a -> b
$ Response -> Maybe (HeaderName, ByteString)
locationHeader Response
resp
      locationURI :: URI
locationURI = Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI String
location
      locationHost :: String
locationHost = URIAuth -> String
uriRegName (Maybe URIAuth -> URIAuth
forall a. HasCallStack => Maybe a -> a
fromJust (URI
locationURI URI -> (URI -> Maybe URIAuth) -> Maybe URIAuth
forall a b. a -> (a -> b) -> b
& URI -> Maybe URIAuth
uriAuthority))
   in String
locationHost

locationHeader :: Response -> Maybe (HTTP.HeaderName, ByteString)
locationHeader :: Response -> Maybe (HeaderName, ByteString)
locationHeader = HeaderName -> Response -> Maybe (HeaderName, ByteString)
findHeader HeaderName
hLocation

findHeader :: HTTP.HeaderName -> Response -> Maybe (HTTP.HeaderName, ByteString)
findHeader :: HeaderName -> Response -> Maybe (HeaderName, ByteString)
findHeader HeaderName
name Response
resp = ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(HeaderName
name', ByteString
_) -> HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
name') Response
resp.headers

getQueryParam :: String -> String -> Maybe (Maybe String)
getQueryParam :: String -> String -> Maybe (Maybe String)
getQueryParam String
name String
url =
  String -> Maybe URI
parseURI String
url
    Maybe URI -> (URI -> Maybe (Maybe String)) -> Maybe (Maybe String)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> [(String, Maybe String)] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name
      ([(String, Maybe String)] -> Maybe (Maybe String))
-> (URI -> [(String, Maybe String)]) -> URI -> Maybe (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Maybe ByteString) -> (String, Maybe String))
-> [(ByteString, Maybe ByteString)] -> [(String, Maybe String)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> String)
-> (Maybe ByteString -> Maybe String)
-> (ByteString, Maybe ByteString)
-> (String, Maybe String)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ((ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>) ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs))
      ([(ByteString, Maybe ByteString)] -> [(String, Maybe String)])
-> (URI -> [(ByteString, Maybe ByteString)])
-> URI
-> [(String, Maybe String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, Maybe ByteString)]
parseQuery
      (ByteString -> [(ByteString, Maybe ByteString)])
-> (URI -> ByteString) -> URI -> [(ByteString, Maybe ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs
      (String -> ByteString) -> (URI -> String) -> URI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
uriQuery