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
  Request
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
  Request -> m Request
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ Request
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
  Response ByteString
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

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
res Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
unauthorized401) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    GlobusError -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (GlobusError -> m ()) -> GlobusError -> m ()
forall a b. (a -> b) -> a -> b
$ Request -> ByteString -> GlobusError
Unauthorized Request
req (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res)

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
res Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    GlobusError -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (GlobusError -> m ()) -> GlobusError -> m ()
forall a b. (a -> b) -> a -> b
$ Request -> Status -> ByteString -> GlobusError
ResponseBadStatus Request
req (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
res) (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res)

  case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
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)