@@ -0,0 +1,98 @@
1+-- |
2+-- Module : Network.Google.Env
3+-- Copyright : (c) 2015 Brendan Hay
4+-- License : Mozilla Public License, v. 2.0.
5+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
6+-- Stability : provisional
7+-- Portability : non-portable (GHC extensions)
8+--
9+-- Environment and Google specific configuration for the 'Network.Google' monad.
10+module Network.Google.Env where
11+
12+import Control.Applicative
13+import Control.Lens
14+import Control.Monad
15+import Control.Monad.Catch
16+import Control.Monad.IO.Class
17+import Control.Monad.Reader
18+import Control.Retry
19+import Data.Monoid
20+import Network.Google.Auth
21+import Network.Google.Internal.Types
22+import Network.Google.Types
23+import Network.HTTP.Conduit
24+
25+-- | The environment containing the parameters required to make Google requests.
26+data Env = Env
27+ { _envRetryCheck :: !(Int -> HttpException -> Bool)
28+ , _envRetryPolicy :: !RetryPolicy
29+ , _envTimeout :: !(Maybe Seconds)
30+ , _envManager :: !Manager
31+ , _envAuth :: !Auth
32+ }
33+
34+-- Note: The strictness annotations aobe are applied to ensure
35+-- total field initialisation.
36+
37+class HasEnv a where
38+ environment :: Lens' a Env
39+ {-# MINIMAL environment #-}
40+
41+ -- | The function used to determine if an 'HttpException' should be retried.
42+ envRetryCheck :: Lens' a (Int -> HttpException -> Bool)
43+
44+ -- | TODO
45+ envRetryPolicy :: Lens' a RetryPolicy
46+
47+ -- | TODO
48+ envTimeout :: Lens' a (Maybe Seconds)
49+
50+ -- | The 'Manager' used to create and manage open HTTP connections.
51+ envManager :: Lens' a Manager
52+
53+ -- | The credentials used to sign requests for authentication with Google.
54+ envAuth :: Lens' a Auth
55+
56+ envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a })
57+ envRetryPolicy = environment . lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a })
58+ envTimeout = environment . lens _envTimeout (\s a -> s { _envTimeout = a })
59+ envManager = environment . lens _envManager (\s a -> s { _envManager = a })
60+ envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })
61+
62+instance HasEnv Env where
63+ environment = id
64+
65+-- | Scope an action such that any retry logic for the 'Env' is
66+-- ignored and any requests will at most be sent once.
67+once :: (MonadReader r m, HasEnv r) => m a -> m a
68+once = policy (limitRetries 0)
69+
70+-- | TODO
71+policy :: (MonadReader r m, HasEnv r) => RetryPolicy -> m a -> m a
72+policy r = local (envRetryPolicy <>~ r)
73+
74+-- | Scope an action such that any HTTP response will use this timeout value.
75+--
76+-- Default timeouts are chosen by considering:
77+--
78+-- * This 'timeout', if set.
79+--
80+-- * The 'envManager' timeout if set.
81+--
82+-- * The default 'ClientRequest' timeout. (Approximately 30s)
83+timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a
84+timeout s = local (envTimeout ?~ s)
85+
86+-- | Creates a new environment with a new 'Manager' without debug logging
87+-- and uses 'getAuth' to expand/discover the supplied 'Credentials'.
88+-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
89+--
90+-- /See:/ 'newEnvWith'.
91+newEnv :: (MonadIO m, MonadCatch m) => Credentials -> m Env
92+newEnv c = liftIO (newManager conduitManagerSettings) >>= newEnvWith c
93+
94+-- | /See:/ 'newEnv'
95+newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env
96+newEnvWith c m = Env check mempty Nothing m <$> getAuth c
97+ where
98+ check _ _ = True