module Effectful.Globus
  ( Globus (..)
  , GlobusClient (..)
  , runGlobus
  , State (..)
  , Tagged (..)
  , TransferRequest (..)
  , TransferResponse (..)
  , TransferItem (..)
  , SyncLevel (..)
  , Task (..)
  , TaskStatus (..)
  , TaskFilters (..)
  , TaskList (..)
  , module Network.Globus.Types
  , requireScopeToken
  ) where

import Control.Monad.Catch (catch)
import Data.List.NonEmpty (NonEmpty)
import Data.Tagged
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
import Network.Globus.Auth
import Network.Globus.Transfer
import Network.Globus.Types hiding (appendQuery, param)
import Network.HTTP.Client (Manager)


data GlobusClient = GlobusClient
  { GlobusClient -> Token 'ClientId
clientId :: Token ClientId
  , GlobusClient -> Token 'ClientSecret
clientSecret :: Token ClientSecret
  }


data Globus :: Effect where
  AuthUrl :: Uri Redirect -> NonEmpty Scope -> State -> Globus m (Uri Authorization)
  GetUserInfo :: Token OpenId -> Globus m UserInfoResponse
  GetAccessTokens :: Token Exchange -> Uri Redirect -> Globus m (NonEmpty TokenItem)
  GetSubmissionId :: Token Access -> Globus m (Id Submission)
  Transfer :: Token Access -> TransferRequest -> Globus m TransferResponse
  StatusTask :: Token Access -> Id Task -> Globus m Task
  StatusTasks :: Token Access -> TaskFilters -> Globus m TaskList


type instance DispatchOf Globus = 'Dynamic


runGlobus
  :: (IOE :> es, Error GlobusError :> es)
  => GlobusClient
  -> Manager
  -> Eff (Globus : es) a
  -> Eff es a
runGlobus :: forall (es :: [Effect]) a.
(IOE :> es, Error GlobusError :> es) =>
GlobusClient -> Manager -> Eff (Globus : es) a -> Eff es a
runGlobus GlobusClient
g Manager
mgr = EffectHandler Globus es -> Eff (Globus : es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
EffectHandler e es -> Eff (e : es) a -> Eff es a
interpret (EffectHandler Globus es -> Eff (Globus : es) a -> Eff es a)
-> EffectHandler Globus es -> Eff (Globus : es) a -> Eff es a
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs es
_ -> \case
  GetAccessTokens Token 'Exchange
exc Uri 'Redirect
red -> do
    IO a -> Eff es a
forall (es :: [Effect]) a.
(IOE :> es, Error GlobusError :> es) =>
IO a -> Eff es a
runGlobusIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Manager
-> Token 'ClientId
-> Token 'ClientSecret
-> Uri 'Redirect
-> Token 'Exchange
-> IO (NonEmpty TokenItem)
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadCatch m) =>
Manager
-> Token 'ClientId
-> Token 'ClientSecret
-> Uri 'Redirect
-> Token 'Exchange
-> m (NonEmpty TokenItem)
fetchAccessTokens Manager
mgr GlobusClient
g.clientId GlobusClient
g.clientSecret Uri 'Redirect
red Token 'Exchange
exc
  GetUserInfo Token 'OpenId
ti -> do
    IO a -> Eff es a
forall (es :: [Effect]) a.
(IOE :> es, Error GlobusError :> es) =>
IO a -> Eff es a
runGlobusIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Manager -> Token 'OpenId -> IO UserInfoResponse
forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadThrow m) =>
Manager -> Token 'OpenId -> m UserInfoResponse
fetchUserInfo Manager
mgr Token 'OpenId
ti
  AuthUrl Uri 'Redirect
red NonEmpty Scope
scopes State
state -> do
    Tagged 'Authorization URI -> Eff es (Tagged 'Authorization URI)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tagged 'Authorization URI -> Eff es (Tagged 'Authorization URI))
-> Tagged 'Authorization URI -> Eff es (Tagged 'Authorization URI)
forall a b. (a -> b) -> a -> b
$ Token 'ClientId
-> Uri 'Redirect
-> NonEmpty Scope
-> State
-> Tagged 'Authorization URI
authorizationUrl GlobusClient
g.clientId Uri 'Redirect
red NonEmpty Scope
scopes State
state
  GetSubmissionId Token 'Access
access -> do
    IO a -> Eff es a
forall (es :: [Effect]) a.
(IOE :> es, Error GlobusError :> es) =>
IO a -> Eff es a
runGlobusIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Manager -> Token 'Access -> IO (Tagged 'Submission Text)
forall (m :: * -> *).
(MonadThrow m, MonadCatch m, MonadIO m) =>
Manager -> Token 'Access -> m (Tagged 'Submission Text)
fetchSubmissionId Manager
mgr Token 'Access
access
  Transfer Token 'Access
access TransferRequest
request -> do
    IO a -> Eff es a
forall (es :: [Effect]) a.
(IOE :> es, Error GlobusError :> es) =>
IO a -> Eff es a
runGlobusIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Manager -> Token 'Access -> TransferRequest -> IO TransferResponse
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadCatch m) =>
Manager -> Token 'Access -> TransferRequest -> m TransferResponse
sendTransfer Manager
mgr Token 'Access
access TransferRequest
request
  StatusTask Token 'Access
access Id Task
ti -> do
    IO a -> Eff es a
forall (es :: [Effect]) a.
(IOE :> es, Error GlobusError :> es) =>
IO a -> Eff es a
runGlobusIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Manager -> Token 'Access -> Id Task -> IO Task
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadCatch m) =>
Manager -> Token 'Access -> Id Task -> m Task
fetchTask Manager
mgr Token 'Access
access Id Task
ti
  StatusTasks Token 'Access
access TaskFilters
tf -> do
    IO a -> Eff es a
forall (es :: [Effect]) a.
(IOE :> es, Error GlobusError :> es) =>
IO a -> Eff es a
runGlobusIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Manager -> Token 'Access -> TaskFilters -> IO TaskList
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadCatch m) =>
Manager -> Token 'Access -> TaskFilters -> m TaskList
fetchTasks Manager
mgr Token 'Access
access TaskFilters
tf
 where
  onGlobusErr :: (Error GlobusError :> es) => GlobusError -> Eff es a
  onGlobusErr :: forall (es :: [Effect]) a.
(Error GlobusError :> es) =>
GlobusError -> Eff es a
onGlobusErr = GlobusError -> Eff es a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError

  runGlobusIO :: (IOE :> es, Error GlobusError :> es) => IO a -> Eff es a
  runGlobusIO :: forall (es :: [Effect]) a.
(IOE :> es, Error GlobusError :> es) =>
IO a -> Eff es a
runGlobusIO IO a
ma = Eff es a -> (GlobusError -> Eff es a) -> Eff es a
forall e a.
(HasCallStack, Exception e) =>
Eff es a -> (e -> Eff es a) -> Eff es a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (IO a -> Eff es a
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
ma) GlobusError -> Eff es a
forall (es :: [Effect]) a.
(Error GlobusError :> es) =>
GlobusError -> Eff es a
onGlobusErr


requireScopeToken :: (Error GlobusError :> es) => Scope -> NonEmpty TokenItem -> Eff es (Token a)
requireScopeToken :: forall {k} (es :: [Effect]) (a :: k).
(Error GlobusError :> es) =>
Scope -> NonEmpty TokenItem -> Eff es (Token a)
requireScopeToken Scope
s NonEmpty TokenItem
tis = do
  Tagged Text
t <- Eff es (Token 'Access)
-> (Token 'Access -> Eff es (Token 'Access))
-> Maybe (Token 'Access)
-> Eff es (Token 'Access)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GlobusError -> Eff es (Token 'Access)
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es, Show e) =>
e -> Eff es a
throwError (GlobusError -> Eff es (Token 'Access))
-> GlobusError -> Eff es (Token 'Access)
forall a b. (a -> b) -> a -> b
$ Scope -> NonEmpty TokenItem -> GlobusError
MissingScope Scope
s NonEmpty TokenItem
tis) Token 'Access -> Eff es (Token 'Access)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Token 'Access) -> Eff es (Token 'Access))
-> Maybe (Token 'Access) -> Eff es (Token 'Access)
forall a b. (a -> b) -> a -> b
$ Scope -> NonEmpty TokenItem -> Maybe (Token 'Access)
scopeToken Scope
s NonEmpty TokenItem
tis
  Token a -> Eff es (Token a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token a -> Eff es (Token a)) -> Token a -> Eff es (Token a)
forall a b. (a -> b) -> a -> b
$ Text -> Token a
forall {k} (s :: k) b. b -> Tagged s b
Tagged Text
t