module Network.Globus.Request where

import Control.Monad (unless, when)
import Control.Monad.Catch (MonadCatch, MonadThrow, SomeException, catch, throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode, encode)
import Data.Tagged
import Data.Text.Encoding (encodeUtf8)
import Network.Globus.Types
import Network.HTTP.Client as Http
import Network.HTTP.Types


request :: (MonadThrow m, MonadCatch m) => Method -> Uri a -> [Header] -> RequestBody -> m Http.Request
request :: forall {k} (m :: * -> *) (a :: k).
(MonadThrow m, MonadCatch m) =>
Method -> Uri a -> [Header] -> RequestBody -> m Request
request Method
m (Tagged URI
u) [Header]
hs RequestBody
body = do
  req <- m Request -> (SomeException -> m Request) -> m Request
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (URI -> m Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
Http.requestFromURI URI
u) SomeException -> m Request
forall (m :: * -> *) a. MonadThrow m => SomeException -> m a
invalidUri
  pure $ req{method = m, requestHeaders = hs, requestBody = body}
 where
  invalidUri :: (MonadThrow m) => SomeException -> m a
  invalidUri :: forall (m :: * -> *) a. MonadThrow m => SomeException -> m a
invalidUri SomeException
e = GlobusError -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (GlobusError -> m a) -> GlobusError -> m a
forall a b. (a -> b) -> a -> b
$ String -> URI -> GlobusError
InvalidURI (SomeException -> String
forall a. Show a => a -> String
show SomeException
e) URI
u


get :: (MonadThrow m, MonadCatch m) => Uri a -> [Header] -> m Http.Request
get :: forall {k} (m :: * -> *) (a :: k).
(MonadThrow m, MonadCatch m) =>
Uri a -> [Header] -> m Request
get Uri a
u [Header]
hs = Method -> Uri a -> [Header] -> RequestBody -> m Request
forall {k} (m :: * -> *) (a :: k).
(MonadThrow m, MonadCatch m) =>
Method -> Uri a -> [Header] -> RequestBody -> m Request
request Method
methodGet Uri a
u [Header]
hs RequestBody
""


post :: (MonadThrow m, MonadCatch m, ToJSON b) => Uri a -> [Header] -> b -> m Http.Request
post :: forall {k} (m :: * -> *) b (a :: k).
(MonadThrow m, MonadCatch m, ToJSON b) =>
Uri a -> [Header] -> b -> m Request
post Uri a
u [Header]
hs b
b = Method -> Uri a -> [Header] -> RequestBody -> m Request
forall {k} (m :: * -> *) (a :: k).
(MonadThrow m, MonadCatch m) =>
Method -> Uri a -> [Header] -> RequestBody -> m Request
request Method
methodPost Uri a
u [Header]
hs (ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ b -> ByteString
forall a. ToJSON a => a -> ByteString
encode b
b)


sendJSON :: (MonadIO m, FromJSON a, MonadThrow m) => Manager -> Request -> m a
sendJSON :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a, MonadThrow m) =>
Manager -> Request -> m a
sendJSON Manager
mgr Request
req = do
  res <- IO (Response ByteString) -> m (Response ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
Http.httpLbs Request
req Manager
mgr

  when (responseStatus res == unauthorized401) $ do
    throwM $ Unauthorized req (responseBody res)

  unless (responseStatus res == status200) $ do
    throwM $ ResponseBadStatus req (responseStatus res) (responseBody res)

  case eitherDecode (responseBody res) of
    Left String
e -> GlobusError -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (GlobusError -> m a) -> GlobusError -> m a
forall a b. (a -> b) -> a -> b
$ Request -> String -> ByteString -> GlobusError
ResponseBadJSON Request
req (String -> String
forall a. Show a => a -> String
show String
e) (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res)
    Right a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a


oAuth2Bearer :: Token a -> Header
oAuth2Bearer :: forall {k} (a :: k). Token a -> Header
oAuth2Bearer (Tagged Text
tok) = (HeaderName
"Authorization", Method
"Bearer " Method -> Method -> Method
forall a. Semigroup a => a -> a -> a
<> Text -> Method
encodeUtf8 Text
tok)