git.iko.soy/gogol
on develop help sign in
Adding GCE detection
49bf8c9Brendan Hay
core/src/Network/Google/Types.hs+5−4
compare with develop
unifiedsplit
@@ -41,6 +41,7 @@ import Data.DList (DList)
41import qualified Data.DList as DList
41import qualified Data.DList as DList
42import Data.Foldable (foldl')
42import Data.Foldable (foldl')
43import Data.Monoid
43import Data.Monoid
44+import Data.String
44import Data.Text (Text)
45import Data.Text (Text)
45import qualified Data.Text.Encoding as Text
46import qualified Data.Text.Encoding as Text
46import Data.Text.Lazy.Builder (Builder)
47import Data.Text.Lazy.Builder (Builder)
@@ -69,10 +70,10 @@ newtype AuthKey = AuthKey Text
69 deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)
70 deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)
70
71
71newtype OAuthToken = OAuthToken { tokenToText :: Text }
72newtype OAuthToken = OAuthToken { tokenToText :: Text }
72− deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)
73+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
73
74
74newtype OAuthScope = OAuthScope { scopeToText :: Text }
75newtype OAuthScope = OAuthScope { scopeToText :: Text }
75− deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)
76+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
76
77
77newtype Bearer a = Bearer a
78newtype Bearer a = Bearer a
78
79
@@ -99,10 +100,10 @@ type Body = Source IO ByteString
99type Stream = ResumableSource (ResourceT IO) ByteString
100type Stream = ResumableSource (ResourceT IO) ByteString
100
101
101newtype ClientId = ClientId { clientIdToText :: Text }
102newtype ClientId = ClientId { clientIdToText :: Text }
102− deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)
103+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
103
104
104newtype ServiceId = ServiceId { serviceIdToText :: Text }
105newtype ServiceId = ServiceId { serviceIdToText :: Text }
105− deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)
106+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
106
107
107data Error
108data Error
108 = TransportError HttpException
109 = TransportError HttpException
gen/src/Gen/Syntax.hs+1−3
@@ -49,9 +49,7 @@ scopeSig :: Name -> Decl
49scopeSig n = TypeSig noLoc [n] (TyCon "OAuthScope")
49scopeSig n = TypeSig noLoc [n] (TyCon "OAuthScope")
50
50
51scopeDecl :: Name -> Text -> Decl
51scopeDecl :: Name -> Text -> Decl
52−scopeDecl n s = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
52+scopeDecl n s = sfun noLoc n [] (UnGuardedRhs (str s)) noBinds
53− where
54− rhs = app (var "OAuthScope") (str s)
55
53
56 -- type API = :<|> ...
54 -- type API = :<|> ...
57apiAlias :: Name -> [Name] -> Decl
55apiAlias :: Name -> [Name] -> Decl
gogol/src/Network/Google/Auth.hs+161−178
@@ -22,7 +22,8 @@ module Network.Google.Auth where
22
22
23import Control.Concurrent
23import Control.Concurrent
24import Control.Concurrent.MVar
24import Control.Concurrent.MVar
25+import Data.Char (toLower)
25−import Control.Exception
26+-- import Control.Exception
26import Control.Exception.Lens
27import Control.Exception.Lens
27import Control.Lens
28import Control.Lens
28import Control.Monad
29import Control.Monad
@@ -40,7 +41,6 @@ import Data.Time
40import Data.Typeable
41import Data.Typeable
41import Network.Google.Prelude
42import Network.Google.Prelude
42import Network.HTTP.Conduit
43import Network.HTTP.Conduit
43−-- import qualified Network.HTTP.Client.Conduit as C
44import qualified Network.HTTP.Conduit as Client
44import qualified Network.HTTP.Conduit as Client
45import Network.HTTP.Types
45import Network.HTTP.Types
46import System.Directory (doesFileExist, getHomeDirectory)
46import System.Directory (doesFileExist, getHomeDirectory)
@@ -48,28 +48,141 @@ import System.Environment (lookupEnv)
48import System.FilePath ((</>))
48import System.FilePath ((</>))
49import System.Info (os)
49import System.Info (os)
50
50
51+data AuthError
52+ = RetrievalError HttpException
53+ | MissingFileError FilePath
54+ | InvalidFileError FilePath Text
55+ | TokenRefreshError Status Text (Maybe Text)
56+ deriving (Show, Typeable)
57+
58+instance Exception AuthError
59+
60+class AsAuthError a where
61+ -- | A general authentication error.
62+ _AuthError :: Prism' a AuthError
63+ {-# MINIMAL _AuthError #-}
64+
65+ -- | An error occured while communicating over HTTP with either then
66+ -- local metadata or remote accounts.google.com endpoints.
67+ _RetrievalError :: Prism' a HttpException
68+
69+ -- | The specified default credentials file could not be found.
70+ _MissingFileError :: Prism' a FilePath
71+
72+ -- | An error occured parsing the default credentials file.
73+ _InvalidFileError :: Prism' a (FilePath, Text)
74+
75+ _RetrievalError = _AuthError . _RetrievalError
76+ _MissingFileError = _AuthError . _MissingFileError
77+ _InvalidFileError = _AuthError . _InvalidFileError
78+
79+instance AsAuthError SomeException where
80+ _AuthError = exception
81+
82+instance AsAuthError AuthError where
83+ _AuthError = id
84+
85+ -- _RetrievalError = prism RetrievalError $ \case
86+ -- RetrievalError e -> Right e
87+ -- x -> Left x
88+
89+ -- _MissingEnvError = prism MissingEnvError $ \case
90+ -- MissingEnvError e -> Right e
91+ -- x -> Left x
92+
93+ -- _MissingFileError = prism MissingFileError $ \case
94+ -- MissingFileError f -> Right f
95+ -- x -> Left x
96+
97+ -- _InvalidFileError = prism InvalidFileError $ \case
98+ -- InvalidFileError e -> Right e
99+ -- x -> Left x
100+
101+accountsHost = "accounts.google.com"
102+
103+metadataHost = "metadata.google.internal"
104+metadataFlavorHeader = "Metadata-Flavor"
105+metadataFlavorDesired = "Google"
106+
107+noGCECheck = "NO_GCE_CHECK"
108+
109+detectGCE :: MonadIO m => Manager -> m Bool
110+detectGCE m = liftIO $ do
111+ p <- check <$> lookupEnv noGCECheck
112+ if p
113+ then (success <$> httpLbs rq m) `catch` failure
114+ else pure False
115+ where
116+ check Nothing = True
117+ check (Just x) = map toLower x `notElem` ["1", "true", "yes", "on"]
118+
119+ success rs =
120+ fromEnum (responseStatus rs) == 200
121+ && (lookup metadataFlavorHeader (responseHeaders rs)
122+ == Just metadataFlavorDesired)
123+
124+ failure :: HttpException -> IO Bool
125+ failure = const (pure False)
126+
127+ rq = def
128+ { Client.host = metadataHost
129+ , Client.checkStatus = \_ _ _ -> Nothing
130+ , Client.responseTimeout = Just 1000000
131+ , Client.requestHeaders =
132+ [ (metadataFlavorHeader, metadataFlavorDesired)
133+ ]
134+ }
135+
136+-- | The environment variable name which can replace ~/.config if set.
137+cloudSDKCredentialsDirVar = "CLOUDSDK_CONFIG"
138+cloudSDKCredentialsDir = "gcloud"
139+cloudSDKCredentialsFile = "application_default_credentials.json"
140+
141+cloudSDKCredentialsPath :: MonadIO m => m FilePath
142+cloudSDKCredentialsPath = liftIO $ do
143+ v <- lookupEnv cloudSDKCredentialsDirVar
144+ h <- getHomeDirectory
145+ let d = case v of
146+ Nothing | os == "windows" -> h </> cloudSDKCredentialsDir
147+ Nothing -> h </> ".config" </> cloudSDKCredentialsDir
148+ Just x -> h </> x
149+ pure $! d </> cloudSDKCredentialsFile
150+
151+-- | The environment variable pointing the file with local
152+-- Application Default Credentials.
153+defaultCredentialsFileVar = "GOOGLE_APPLICATION_CREDENTIALS"
154+
155+defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
156+defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFileVar)
157+
51data Credentials
158data Credentials
52− = FromToken !OAuthToken
159+ = FromToken !OAuthToken
53− | FromFile !FilePath
160+ | FromFile !FilePath
161+ | FromAccount !ServiceId
54 | Discover
162 | Discover
55 deriving (Eq, Show)
163 deriving (Eq, Show)
56
164
57−getAuth :: MonadIO m => Manager -> Credentials -> m Auth
165+getAuth :: (MonadIO m, MonadCatch m) => Manager -> Credentials -> m Auth
58getAuth m = \case
166getAuth m = \case
59− FromToken t -> pure (fromToken t)
167+ FromToken t -> pure (fromToken t)
60− FromFile f -> fromFilePath m f
168+ FromFile f -> fromFilePath m f
169+ FromAccount s -> fromAccount m s
61− Discover -> undefined
170+ Discover ->
62− -- catching _MissingFileError fromFile $ \f -> do
171+ catching _MissingFileError (fromFile m) $ \f -> do
63− -- p <- detectGCE m
172+ p <- detectGCE m
64− -- unless p $
173+ unless p $
65− -- throwingM _MissingFileError f
174+ throwingM _MissingFileError f
66− -- fromMetadata m
175+ fromAccount m "default"
67
176
68fromToken :: OAuthToken -> Auth
177fromToken :: OAuthToken -> Auth
69fromToken = Tok
178fromToken = Tok
70
179
71fromFile :: MonadIO m => Manager -> m Auth
180fromFile :: MonadIO m => Manager -> m Auth
181+fromFile m = do
72−fromFile m = defaultCredentialsPath >>= fromFilePath m
182+ mf <- defaultCredentialsPath
183+ case mf of
184+ Just f -> fromFilePath m f
185+ Nothing -> cloudSDKCredentialsPath >>= fromFilePath m
73
186
74fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth
187fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth
75fromFilePath m f = liftIO $ do
188fromFilePath m f = liftIO $ do
@@ -81,8 +194,8 @@ fromFilePath m f = liftIO $ do
81 !r <- refresh m u
194 !r <- refresh m u
82 Ref m <$> newMVar (r :: Refresh User)
195 Ref m <$> newMVar (r :: Refresh User)
83
196
84−fromMetadata :: MonadIO m => Manager -> ServiceId -> m Auth
197+fromAccount :: MonadIO m => Manager -> ServiceId -> m Auth
85−fromMetadata m s = liftIO $ do
198+fromAccount m s = liftIO $ do
86 !r <- refresh m s
199 !r <- refresh m s
87 Ref m <$> newMVar (r :: Refresh ServiceId)
200 Ref m <$> newMVar (r :: Refresh ServiceId)
88
201
@@ -111,145 +224,6 @@ refreshToken (Ref m r) = do
111isValid :: Refresh a -> IO Bool
224isValid :: Refresh a -> IO Bool
112isValid r = (< _rExpiry r) <$> getCurrentTime
225isValid r = (< _rExpiry r) <$> getCurrentTime
113
226
114−-- GOOGLE_AUTH_URI = 'https://accounts.google.com/o/oauth2/auth'
115−-- GOOGLE_DEVICE_URI = 'https://accounts.google.com/o/oauth2/device/code'
116−-- GOOGLE_REVOKE_URI = 'https://accounts.google.com/o/oauth2/revoke'
117−-- GOOGLE_TOKEN_URI = 'https://accounts.google.com/o/oauth2/token'
118−-- GOOGLE_TOKEN_INFO_URI = 'https://www.googleapis.com/oauth2/v2/tokeninfo'
119−
120−-- -- | Which certs to use to validate id_tokens received.
121−-- ID_TOKEN_VERIFICATION_CERTS = "https://www.googleapis.com/oauth2/v1/certs"
122−
123−-- -- | Google Data client libraries may need to set this to [401, 403].
124−-- REFRESH_STATUS_CODES = [401]
125−
126−-- -- | The value representing user credentials.
127−-- AUTHORIZED_USER = "authorized_user"
128−
129−-- -- | The value representing service account credentials.
130−-- SERVICE_ACCOUNT = "service_account"
131−
132−-- -- | The environment variable pointing the file with local
133−-- -- Application Default Credentials.
134−-- GOOGLE_APPLICATION_CREDENTIALS = "GOOGLE_APPLICATION_CREDENTIALS"
135−
136−
137−-- _SERVER_SOFTWARE = 'SERVER_SOFTWARE'
138−-- _GCE_METADATA_HOST = '169.254.169.254'
139−-- _METADATA_FLAVOR_HEADER = 'Metadata-Flavor'
140−-- _DESIRED_METADATA_FLAVOR = 'Google'
141−
142−-- NO_GCE_CHECK = os.environ.setdefault('NO_GCE_CHECK', 'False')
143−
144−-- # The error message we show users when we can't find the Application
145−-- # Default Credentials.
146−-- ADC_HELP_MSG = (
147−-- 'The Application Default Credentials are not available. They are '
148−-- 'available if running in Google Compute Engine. Otherwise, the '
149−-- 'environment variable ' +
150−-- GOOGLE_APPLICATION_CREDENTIALS +
151−-- ' must be defined pointing to a file defining the credentials. See '
152−-- 'https://developers.google.com/accounts/docs/'
153−-- 'application-default-credentials for more information.')
154−
155−-- # The access token along with the seconds in which it expires.
156−-- AccessTokenInfo = collections.namedtuple(
157−-- 'AccessTokenInfo', ['access_token', 'expires_in'])
158−
159−-- DEFAULT_ENV_NAME = 'UNKNOWN'
160−
161−detectGCE :: MonadIO m => Manager -> m Bool
162−detectGCE m = pure False
163−
164−-- def _detect_gce_environment():
165−-- """Determine if the current environment is Compute Engine.
166−-- Returns:
167−-- Boolean indicating whether or not the current environment is Google
168−-- Compute Engine.
169−-- """
170−-- # NOTE: The explicit ``timeout`` is a workaround. The underlying
171−-- # issue is that resolving an unknown host on some networks will take
172−-- # 20-30 seconds; making this timeout short fixes the issue, but
173−-- # could lead to false negatives in the event that we are on GCE, but
174−-- # the metadata resolution was particularly slow. The latter case is
175−-- # "unlikely".
176−-- connection = six.moves.http_client.HTTPConnection(
177−-- _GCE_METADATA_HOST, timeout=1)
178−
179−-- try:
180−-- headers = {_METADATA_FLAVOR_HEADER: _DESIRED_METADATA_FLAVOR}
181−-- connection.request('GET', '/', headers=headers)
182−-- response = connection.getresponse()
183−-- if response.status == 200:
184−-- return (response.getheader(_METADATA_FLAVOR_HEADER) ==
185−-- _DESIRED_METADATA_FLAVOR)
186−-- except socket.error: # socket.timeout or socket.error(64, 'Host is down')
187−-- logger.info('Timeout attempting to reach GCE metadata service.')
188−-- return False
189−-- finally:
190−-- connection.close()
191−
192−-- isGAE :: MonadIO m => m Bool
193−-- isGAE = pure False
194− -- if SETTINGS.env_name is not None:
195− -- return SETTINGS.env_name in ('GAE_PRODUCTION', 'GAE_LOCAL')
196−
197− -- try:
198− -- import google.appengine
199− -- server_software = os.environ.get(_SERVER_SOFTWARE, '')
200− -- if server_software.startswith('Google App Engine/'):
201− -- SETTINGS.env_name = 'GAE_PRODUCTION'
202− -- return True
203− -- elif server_software.startswith('Development/'):
204− -- SETTINGS.env_name = 'GAE_LOCAL'
205− -- return True
206− -- except ImportError:
207− -- pass
208−
209− -- return False
210−
211−-- isGCE :: MonadIO m => m Bool
212−-- isGCE = pure False
213−-- def _in_gce_environment():
214−-- """Detect if the code is running in the Compute Engine environment.
215−-- Returns:
216−-- True if running in the GCE environment, False otherwise.
217−-- """
218−-- if SETTINGS.env_name is not None:
219−-- return SETTINGS.env_name == 'GCE_PRODUCTION'
220−
221−-- if NO_GCE_CHECK != 'True' and _detect_gce_environment():
222−-- SETTINGS.env_name = 'GCE_PRODUCTION'
223−-- return True
224−-- return False
225−
226−data AuthError
227− = RetrievalError HttpException
228− | MissingFileError FilePath
229− | InvalidFileError FilePath Text
230− | TokenRefreshError Status Text (Maybe Text)
231− deriving (Show, Typeable)
232−
233−instance Exception AuthError
234−
235−parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
236−parseLBS = either (Left . Text.pack) Right . eitherDecode'
237−
238−-- | The environment variable name which can replace ~/.config if set.
239−cloudSDKConfigDirVar = "CLOUDSDK_CONFIG"
240−cloudSDKConfigDir = "gcloud"
241−cloudSDKConfigFile = "application_default_credentials.json"
242−
243−defaultCredentialsPath :: MonadIO m => m FilePath
244−defaultCredentialsPath = liftIO $ do
245− v <- lookupEnv cloudSDKConfigDirVar
246− h <- getHomeDirectory
247− let d = case v of
248− Nothing | os == "windows" -> h </> cloudSDKConfigDir
249− Nothing -> h </> ".config" </> cloudSDKConfigDir
250− Just x -> h </> x
251− pure $! d </> cloudSDKConfigFile
252−
253data User = User
227data User = User
254 { _uId :: !ClientId
228 { _uId :: !ClientId
255 , _uSecret :: !Text
229 , _uSecret :: !Text
@@ -287,26 +261,22 @@ instance FromJSON (UTCTime -> (Maybe Text -> a) -> Refresh a) where
287 Refresh t (addUTCTime e ts) (f r)
261 Refresh t (addUTCTime e ts) (f r)
288
262
289class RefreshToken a where
263class RefreshToken a where
290− refresh :: Manager -> a -> IO (Refresh a)
264+ refresh :: (MonadIO m, MonadCatch m) => Manager -> a -> m (Refresh a)
291
265
292instance RefreshToken User where
266instance RefreshToken User where
293− refresh m u@User {..} = do
267+ refresh m u@User {..} = perform m rq success failure
294− rs <- httpLbs rq m
295− let bs = responseBody rs
296− s = responseStatus rs
297− if fromEnum s == 200 then success s bs else failure s bs
298 where
268 where
299− failure s bs = do
300− RefreshError {..} <- parseErr s bs
301− refreshErr s _eError _eDescription
302−
303 success s bs = do
269 success s bs = do
304 f <- parseErr s bs
270 f <- parseErr s bs
305− ts <- getCurrentTime
271+ ts <- liftIO getCurrentTime
306 pure $! f ts $ \r ->
272 pure $! f ts $ \r ->
307 u { _uRefresh = fromMaybe _uRefresh r
273 u { _uRefresh = fromMaybe _uRefresh r
308 }
274 }
309
275
276+ failure s bs = do
277+ RefreshError {..} <- parseErr s bs
278+ refreshErr s _eError _eDescription
279+
310 parseErr s bs =
280 parseErr s bs =
311 case parseLBS bs of
281 case parseLBS bs of
312 Left e -> refreshErr s e Nothing
282 Left e -> refreshErr s e Nothing
@@ -315,7 +285,7 @@ instance RefreshToken User where
315 refreshErr s e = throwM . TokenRefreshError s e
285 refreshErr s e = throwM . TokenRefreshError s e
316
286
317 rq = def
287 rq = def
318− { Client.host = "accounts.google.com"
288+ { Client.host = accountsHost
319 , Client.port = 443
289 , Client.port = 443
320 , Client.secure = True
290 , Client.secure = True
321 , Client.checkStatus = \_ _ _ -> Nothing
291 , Client.checkStatus = \_ _ _ -> Nothing
@@ -330,21 +300,17 @@ instance RefreshToken User where
330 }
300 }
331
301
332instance RefreshToken ServiceId where
302instance RefreshToken ServiceId where
333− refresh m sid = do
303+ refresh m sid = perform m rq success failure
334− rs <- httpLbs rq m
335− let bs = responseBody rs
336− s = responseStatus rs
337− if fromEnum s == 200 then success s bs else failure s
338 where
304 where
339− failure s =
340− refreshErr s "Failure refreshing token from http://metadata.google.internal"
341− Nothing
342−
343 success s bs = do
305 success s bs = do
344 f <- parseErr s bs
306 f <- parseErr s bs
345− ts <- getCurrentTime
307+ ts <- liftIO getCurrentTime
346 pure $! f ts (const sid :: Maybe Text -> ServiceId)
308 pure $! f ts (const sid :: Maybe Text -> ServiceId)
347
309
310+ failure s = const $
311+ refreshErr s "Failure refreshing token from http://metadata.google.internal"
312+ Nothing
313+
348 parseErr s bs =
314 parseErr s bs =
349 case parseLBS bs of
315 case parseLBS bs of
350 Left e -> refreshErr s e Nothing
316 Left e -> refreshErr s e Nothing
@@ -353,7 +319,7 @@ instance RefreshToken ServiceId where
353 refreshErr s e = throwM . TokenRefreshError s e
319 refreshErr s e = throwM . TokenRefreshError s e
354
320
355 rq = def
321 rq = def
356− { Client.host = "metadata.google.internal"
322+ { Client.host = metadataHost
357 , Client.port = 80
323 , Client.port = 80
358 , Client.secure = False
324 , Client.secure = False
359 , Client.checkStatus = \_ _ _ -> Nothing
325 , Client.checkStatus = \_ _ _ -> Nothing
@@ -362,3 +328,20 @@ instance RefreshToken ServiceId where
362 <> Text.encodeUtf8 (serviceIdToText sid)
328 <> Text.encodeUtf8 (serviceIdToText sid)
363 <> "/token"
329 <> "/token"
364 }
330 }
331+
332+perform :: (MonadIO m, MonadCatch m)
333+ => Manager
334+ -> Client.Request
335+ -> (Status -> LBS.ByteString -> m a)
336+ -> (Status -> LBS.ByteString -> m a)
337+ -> m a
338+perform m rq success failure = do
339+ rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)
340+ let bs = responseBody rs
341+ s = responseStatus rs
342+ if fromEnum s == 200
343+ then success s bs
344+ else failure s bs
345+
346+parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
347+parseLBS = either (Left . Text.pack) Right . eitherDecode'