@@ -13,15 +13,17 @@ import Control.Lens
13import Control.Monad.Catch
13import Control.Monad.Catch
14import Control.Monad.IO.Class
14import Control.Monad.IO.Class
15import Control.Monad.Reader
15import Control.Monad.Reader
16+import Data.Function (on)
16import Network.Google.Auth
18import Network.Google.Auth
17import Network.Google.Types
19import Network.Google.Types
18import Network.HTTP.Conduit
20import Network.HTTP.Conduit
20-- | The environment containing the parameters required to make Google requests.
22-- | The environment containing the parameters required to make Google requests.
21data Env = Env
23data Env = Env
22− { _envTimeout :: !(Maybe Seconds)
24+ { _envOverride :: !(Dual (Endo Service))
23− , _envManager :: !Manager
25+ , _envManager :: !Manager
24− , _envAuth :: !Auth
26+ , _envAuth :: !Auth
27-- Note: The strictness annotations aobe are applied to ensure
29-- Note: The strictness annotations aobe are applied to ensure
@@ -31,8 +33,8 @@ class HasEnv a where
31 environment :: Lens' a Env
33 environment :: Lens' a Env
32 {-# MINIMAL environment #-}
34 {-# MINIMAL environment #-}
34− -- | TODO
36+ -- | The currently applied overrides to all 'Service' configuration.
35− envTimeout :: Lens' a (Maybe Seconds)
37+ envOverride :: Lens' a (Dual (Endo Service))
37 -- | The 'Manager' used to create and manage open HTTP connections.
39 -- | The 'Manager' used to create and manage open HTTP connections.
38 envManager :: Lens' a Manager
40 envManager :: Lens' a Manager
@@ -40,13 +42,45 @@ class HasEnv a where
40 -- | The credentials used to sign requests for authentication with Google.
42 -- | The credentials used to sign requests for authentication with Google.
41 envAuth :: Lens' a Auth
43 envAuth :: Lens' a Auth
43− envTimeout = environment . lens _envTimeout (\s a -> s { _envTimeout = a })
45+ envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })
44− envManager = environment . lens _envManager (\s a -> s { _envManager = a })
46+ envManager = environment . lens _envManager (\s a -> s { _envManager = a })
45− envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })
47+ envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })
47instance HasEnv Env where
49instance HasEnv Env where
48 environment = id
50 environment = id
52+-- | Provide a function which will be added to the existing stack
53+-- of overrides applied to all service configuration.
55+-- To override a specific service, it's suggested you use
56+-- either 'configure' or 'reconfigure' with a modified version of the default
57+-- service, such as @Network.Google.Gmail.gmail@.
58+override :: HasEnv a => (Service -> Service) -> a -> a
59+override f = envOverride <>~ Dual (Endo f)
61+-- | Configure a specific service. All requests belonging to the
62+-- supplied service will use this configuration instead of the default.
64+-- It's suggested you use a modified version of the default service, such
65+-- as @Network.Google.Gmail.gmail@.
67+-- /See:/ 'reconfigure'.
68+configure :: HasEnv a => Service -> a -> a
69+configure s = override f
71+ f x | on (==) _svcId s x = s
74+-- | Scope an action such that all requests belonging to the supplied service
75+-- will use this configuration instead of the default.
77+-- It's suggested you use a modified version of the default service, such
78+-- as @Network.Google.Gmail.gmail@.
80+-- /See:/ 'configure'.
81+reconfigure :: (MonadReader r m, HasEnv r) => Service -> m a -> m a
82+reconfigure = local . configure
50-- | Scope an action such that any HTTP response will use this timeout value.
84-- | Scope an action such that any HTTP response will use this timeout value.
52-- Default timeouts are chosen by considering:
86-- Default timeouts are chosen by considering:
@@ -59,7 +93,7 @@ instance HasEnv Env where
60-- * The default 'ClientRequest' timeout. (Approximately 30s)
94-- * The default 'ClientRequest' timeout. (Approximately 30s)
61timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a
95timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a
62−timeout s = local (envTimeout ?~ s)
96+timeout s = local (override (serviceTimeout ?~ s))
64-- | Creates a new environment with a new 'Manager' without debug logging
98-- | Creates a new environment with a new 'Manager' without debug logging
65-- and uses 'getAuth' to expand/discover the supplied 'Credentials'.
99-- and uses 'getAuth' to expand/discover the supplied 'Credentials'.
@@ -71,4 +105,4 @@ newEnv c = liftIO (newManager tlsManagerSettings) >>= newEnvWith c
72-- | /See:/ 'newEnv'
106-- | /See:/ 'newEnv'
73newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env
107newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env
74−newEnvWith c m = Env Nothing m <$> getAuth m c
108+newEnvWith c m = Env mempty m <$> getAuth m c