@@ -22,7 +22,8 @@ module Network.Google.Auth where
2222
2323import Control.Concurrent
2424import Control.Concurrent.MVar
25−import Control.Exception
25+import Data.Char (toLower)
26+-- import Control.Exception
2627import Control.Exception.Lens
2728import Control.Lens
2829import Control.Monad
@@ -40,7 +41,6 @@ import Data.Time
4041import Data.Typeable
4142import Network.Google.Prelude
4243import Network.HTTP.Conduit
43−-- import qualified Network.HTTP.Client.Conduit as C
4444import qualified Network.HTTP.Conduit as Client
4545import Network.HTTP.Types
4646import System.Directory (doesFileExist, getHomeDirectory)
@@ -48,28 +48,141 @@ import System.Environment (lookupEnv)
4848import System.FilePath ((</>))
4949import System.Info (os)
5050
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+
51158data Credentials
52− = FromToken !OAuthToken
53− | FromFile !FilePath
159+ = FromToken !OAuthToken
160+ | FromFile !FilePath
161+ | FromAccount !ServiceId
54162 | Discover
55163 deriving (Eq, Show)
56164
57−getAuth :: MonadIO m => Manager -> Credentials -> m Auth
165+getAuth :: (MonadIO m, MonadCatch m) => Manager -> Credentials -> m Auth
58166getAuth m = \case
59− FromToken t -> pure (fromToken t)
60− FromFile f -> fromFilePath m f
61− Discover -> undefined
62− -- catching _MissingFileError fromFile $ \f -> do
63− -- p <- detectGCE m
64− -- unless p $
65− -- throwingM _MissingFileError f
66− -- fromMetadata m
167+ FromToken t -> pure (fromToken t)
168+ FromFile f -> fromFilePath m f
169+ FromAccount s -> fromAccount m s
170+ Discover ->
171+ catching _MissingFileError (fromFile m) $ \f -> do
172+ p <- detectGCE m
173+ unless p $
174+ throwingM _MissingFileError f
175+ fromAccount m "default"
67176
68177fromToken :: OAuthToken -> Auth
69178fromToken = Tok
70179
71180fromFile :: MonadIO m => Manager -> m Auth
72−fromFile m = defaultCredentialsPath >>= fromFilePath m
181+fromFile m = do
182+ mf <- defaultCredentialsPath
183+ case mf of
184+ Just f -> fromFilePath m f
185+ Nothing -> cloudSDKCredentialsPath >>= fromFilePath m
73186
74187fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth
75188fromFilePath m f = liftIO $ do
@@ -81,8 +194,8 @@ fromFilePath m f = liftIO $ do
81194 !r <- refresh m u
82195 Ref m <$> newMVar (r :: Refresh User)
83196
84−fromMetadata :: MonadIO m => Manager -> ServiceId -> m Auth
85−fromMetadata m s = liftIO $ do
197+fromAccount :: MonadIO m => Manager -> ServiceId -> m Auth
198+fromAccount m s = liftIO $ do
86199 !r <- refresh m s
87200 Ref m <$> newMVar (r :: Refresh ServiceId)
88201
@@ -111,145 +224,6 @@ refreshToken (Ref m r) = do
111224isValid :: Refresh a -> IO Bool
112225isValid r = (< _rExpiry r) <$> getCurrentTime
113226
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−
253227data User = User
254228 { _uId :: !ClientId
255229 , _uSecret :: !Text
@@ -287,26 +261,22 @@ instance FromJSON (UTCTime -> (Maybe Text -> a) -> Refresh a) where
287261 Refresh t (addUTCTime e ts) (f r)
288262
289263class RefreshToken a where
290− refresh :: Manager -> a -> IO (Refresh a)
264+ refresh :: (MonadIO m, MonadCatch m) => Manager -> a -> m (Refresh a)
291265
292266instance RefreshToken User where
293− refresh m u@User {..} = do
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
267+ refresh m u@User {..} = perform m rq success failure
298268 where
299− failure s bs = do
300− RefreshError {..} <- parseErr s bs
301− refreshErr s _eError _eDescription
302−
303269 success s bs = do
304270 f <- parseErr s bs
305− ts <- getCurrentTime
271+ ts <- liftIO getCurrentTime
306272 pure $! f ts $ \r ->
307273 u { _uRefresh = fromMaybe _uRefresh r
308274 }
309275
276+ failure s bs = do
277+ RefreshError {..} <- parseErr s bs
278+ refreshErr s _eError _eDescription
279+
310280 parseErr s bs =
311281 case parseLBS bs of
312282 Left e -> refreshErr s e Nothing
@@ -315,7 +285,7 @@ instance RefreshToken User where
315285 refreshErr s e = throwM . TokenRefreshError s e
316286
317287 rq = def
318− { Client.host = "accounts.google.com"
288+ { Client.host = accountsHost
319289 , Client.port = 443
320290 , Client.secure = True
321291 , Client.checkStatus = \_ _ _ -> Nothing
@@ -330,21 +300,17 @@ instance RefreshToken User where
330300 }
331301
332302instance RefreshToken ServiceId where
333− refresh m sid = do
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
303+ refresh m sid = perform m rq success failure
338304 where
339− failure s =
340− refreshErr s "Failure refreshing token from http://metadata.google.internal"
341− Nothing
342−
343305 success s bs = do
344306 f <- parseErr s bs
345− ts <- getCurrentTime
307+ ts <- liftIO getCurrentTime
346308 pure $! f ts (const sid :: Maybe Text -> ServiceId)
347309
310+ failure s = const $
311+ refreshErr s "Failure refreshing token from http://metadata.google.internal"
312+ Nothing
313+
348314 parseErr s bs =
349315 case parseLBS bs of
350316 Left e -> refreshErr s e Nothing
@@ -353,7 +319,7 @@ instance RefreshToken ServiceId where
353319 refreshErr s e = throwM . TokenRefreshError s e
354320
355321 rq = def
356− { Client.host = "metadata.google.internal"
322+ { Client.host = metadataHost
357323 , Client.port = 80
358324 , Client.secure = False
359325 , Client.checkStatus = \_ _ _ -> Nothing
@@ -362,3 +328,20 @@ instance RefreshToken ServiceId where
362328 <> Text.encodeUtf8 (serviceIdToText sid)
363329 <> "/token"
364330 }
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'