@@ -1,4 +1,8 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1−{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RecordWildCards #-}
4-- Module : Network.Google.Auth
8-- Module : Network.Google.Auth
@@ -12,34 +16,358 @@
12-- from the underlying OS.
16-- from the underlying OS.
13module Network.Google.Auth where
17module Network.Google.Auth where
15−import Control.Concurrent (ThreadId)
19+import Control.Concurrent
20+import Control.Concurrent.MVar
21+import Control.Exception
22+import Control.Exception.Lens
24+import Control.Monad.Catch
16import Control.Monad.IO.Class
25import Control.Monad.IO.Class
17−import Data.IORef
26+import Data.Aeson
27+import Data.ByteString (ByteString)
28+import qualified Data.ByteString.Lazy as LBS
29+import Data.Default.Class (def)
30+import qualified Data.HashMap.Strict as Map
31+import Data.Text (Text)
32+import qualified Data.Text as Text
33+import qualified Data.Text.Encoding as Text
18import Network.Google.Prelude
36import Network.Google.Prelude
37+import Network.HTTP.Conduit
38+-- import qualified Network.HTTP.Client.Conduit as C
39+import qualified Network.HTTP.Conduit as Client
40+import Network.HTTP.Types
41+import System.Directory (getHomeDirectory)
42+import System.Environment (lookupEnv)
43+import System.FilePath ((</>))
44+import System.Info (os)
46+-- withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a
47+-- withAuth (Ref _ r) f = liftIO (readIORef r) >>= f
48+-- withAuth (Auth e) f = f e
50+-- -- | Retrieve authentication information via the specified 'Credentials' mechanism.
20−data Credentials
51+-- getAuth :: Monad m => Credentials -> m Auth
21− = FromKey AuthKey
52+-- getAuth = \case
22− | FromToken OAuthToken
53+-- FromKey k -> pure $! Auth (AuthEnv (Left k) Nothing)
54+-- FromToken t -> pure $! Auth (AuthEnv (Right t) Nothing)
57+-- -- | Expiry is stored in RFC3339 UTC format
58+-- EXPIRY_FORMAT = "%Y-%m-%dT%H:%M:%SZ"
60+-- -- | Which certs to use to validate id_tokens received.
61+-- ID_TOKEN_VERIFICATION_CERTS = "https://www.googleapis.com/oauth2/v1/certs"
63+-- -- | Google Data client libraries may need to set this to [401, 403].
64+-- REFRESH_STATUS_CODES = [401]
66+-- -- | The value representing user credentials.
67+-- AUTHORIZED_USER = "authorized_user"
69+-- -- | The value representing service account credentials.
70+-- SERVICE_ACCOUNT = "service_account"
72+-- -- | The environment variable pointing the file with local
73+-- -- Application Default Credentials.
74+-- GOOGLE_APPLICATION_CREDENTIALS = "GOOGLE_APPLICATION_CREDENTIALS"
77+-- _SERVER_SOFTWARE = 'SERVER_SOFTWARE'
78+-- _GCE_METADATA_HOST = '169.254.169.254'
79+-- _METADATA_FLAVOR_HEADER = 'Metadata-Flavor'
80+-- _DESIRED_METADATA_FLAVOR = 'Google'
82+-- NO_GCE_CHECK = os.environ.setdefault('NO_GCE_CHECK', 'False')
84+-- # The error message we show users when we can't find the Application
85+-- # Default Credentials.
87+-- 'The Application Default Credentials are not available. They are '
88+-- 'available if running in Google Compute Engine. Otherwise, the '
89+-- 'environment variable ' +
90+-- GOOGLE_APPLICATION_CREDENTIALS +
91+-- ' must be defined pointing to a file defining the credentials. See '
92+-- 'https://developers.google.com/accounts/docs/'
93+-- 'application-default-credentials for more information.')
95+-- # The access token along with the seconds in which it expires.
96+-- AccessTokenInfo = collections.namedtuple(
97+-- 'AccessTokenInfo', ['access_token', 'expires_in'])
99+-- DEFAULT_ENV_NAME = 'UNKNOWN'
101+detectGCE :: MonadIO m => Manager -> m Bool
102+detectGCE m = pure False
104+-- def _detect_gce_environment():
105+-- """Determine if the current environment is Compute Engine.
107+-- Boolean indicating whether or not the current environment is Google
110+-- # NOTE: The explicit ``timeout`` is a workaround. The underlying
111+-- # issue is that resolving an unknown host on some networks will take
112+-- # 20-30 seconds; making this timeout short fixes the issue, but
113+-- # could lead to false negatives in the event that we are on GCE, but
114+-- # the metadata resolution was particularly slow. The latter case is
116+-- connection = six.moves.http_client.HTTPConnection(
117+-- _GCE_METADATA_HOST, timeout=1)
120+-- headers = {_METADATA_FLAVOR_HEADER: _DESIRED_METADATA_FLAVOR}
121+-- connection.request('GET', '/', headers=headers)
122+-- response = connection.getresponse()
123+-- if response.status == 200:
124+-- return (response.getheader(_METADATA_FLAVOR_HEADER) ==
125+-- _DESIRED_METADATA_FLAVOR)
126+-- except socket.error: # socket.timeout or socket.error(64, 'Host is down')
127+-- logger.info('Timeout attempting to reach GCE metadata service.')
130+-- connection.close()
132+isGAE :: MonadIO m => m Bool
134+ -- if SETTINGS.env_name is not None:
135+ -- return SETTINGS.env_name in ('GAE_PRODUCTION', 'GAE_LOCAL')
138+ -- import google.appengine
139+ -- server_software = os.environ.get(_SERVER_SOFTWARE, '')
140+ -- if server_software.startswith('Google App Engine/'):
141+ -- SETTINGS.env_name = 'GAE_PRODUCTION'
143+ -- elif server_software.startswith('Development/'):
144+ -- SETTINGS.env_name = 'GAE_LOCAL'
146+ -- except ImportError:
151+isGCE :: MonadIO m => m Bool
153+-- def _in_gce_environment():
154+-- """Detect if the code is running in the Compute Engine environment.
156+-- True if running in the GCE environment, False otherwise.
158+-- if SETTINGS.env_name is not None:
159+-- return SETTINGS.env_name == 'GCE_PRODUCTION'
161+-- if NO_GCE_CHECK != 'True' and _detect_gce_environment():
162+-- SETTINGS.env_name = 'GCE_PRODUCTION'
166+newtype ClientId = ClientId { clientId :: Text }
23− deriving (Eq)
167+ deriving (Eq, Show, FromJSON, ToJSON)
25−-- | The authorisation environment.
169+data AuthError
26−data AuthEnv = AuthEnv
170+ = RetrievalError HttpException
27− { _authCreds :: Either AuthKey OAuthToken
171+ | MissingFileError FilePath
28− , _authExpiry :: Maybe UTCTime
172+ | InvalidFileError FilePath Text
173+ | TokenRefreshError Status ClientId Text (Maybe Text)
174+ deriving (Show, Typeable)
176+instance Exception AuthError
178+parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
179+parseLBS = either (Left . Text.pack) Right . eitherDecode'
181+-- | The environment variable name which can replace ~/.config if set.
182+cloudSDKConfigDirVar = "CLOUDSDK_CONFIG"
183+cloudSDKConfigDir = "gcloud"
184+cloudSDKConfigFile = "application_default_credentials.json"
186+defaultCredentialsPath :: MonadIO m => m FilePath
187+defaultCredentialsPath = liftIO $ do
188+ v <- lookupEnv cloudSDKConfigDirVar
189+ h <- getHomeDirectory
191+ Nothing | os == "windows" -> h </> cloudSDKConfigDir
192+ Nothing -> h </> ".config" </> cloudSDKConfigDir
194+ pure $! d </> cloudSDKConfigFile
196+data AuthorizedUser = AuthorizedUser
197+ { _auClientId :: !ClientId
198+ , _auClientSecret :: !Text
199+ , _auRefreshToken :: !Text
202+instance FromJSON AuthorizedUser where
203+ parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser
204+ <$> o .: "client_id"
205+ <*> o .: "client_secret"
206+ <*> o .: "refresh_token"
208+data AuthorizedRefresh = AuthorizedRefresh
209+ { _arAccessToken :: !OAuthToken
210+ , _arRefreshToken :: !(Maybe Text)
211+ , _arExpiresIn :: !NominalDiffTime
31−-- | An authorisation environment containing Google credentials, and potentially
214+instance FromJSON AuthorizedRefresh where
32−-- a reference which can be refreshed out-of-band as credentials expire.
215+ parseJSON = withObject "authorized_refresh" $ \o -> AuthorizedRefresh
216+ <$> o .: "access_token"
217+ <*> o .:? "refresh_token"
218+ <*> (fromInteger <$> o .: "expires_in")
220+data AuthorizedError = AuthorizedError
222+ , _aeDescription :: !(Maybe Text)
225+instance FromJSON AuthorizedError where
226+ parseJSON = withObject "authorized_error" $ \o -> AuthorizedError
228+ <*> o .:? "error_description"
230+refreshUser :: Manager -> AuthorizedUser -> IO (Refresh AuthorizedUser)
231+refreshUser m u@AuthorizedUser {..} = do
233+ let bs = responseBody rs
234+ s = responseStatus rs
235+ if fromEnum s == 200 then success s bs else failure s bs
238+ AuthorizedError {..} <- parseErr s bs
239+ refreshErr s _aeError _aeDescription
242+ AuthorizedRefresh {..} <- parseErr s bs
243+ ts <- getCurrentTime
244+ pure $! Refresh (addUTCTime _arExpiresIn ts) _arAccessToken $
245+ u { _auRefreshToken = fromMaybe _auRefreshToken _arRefreshToken }
249+ Left e -> refreshErr s e Nothing
252+ refreshErr s e = throwM . TokenRefreshError s _auClientId e
255+ { Client.host = "accounts.google.com"
257+ , Client.secure = True
258+ , Client.checkStatus = \_ _ _ -> Nothing
259+ , Client.method = "POST"
260+ , Client.path = "/o/oauth2/token"
261+ , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]
262+ , Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
263+ "grant_type=refresh_token"
264+ <> "&client_id=" <> clientId _auClientId
265+ <> "&client_secret=" <> _auClientSecret
266+ <> "&refresh_token=" <> _auRefreshToken
269+-- data ServiceAccount = ServiceAccount
270+-- { _saClientId :: !Text
271+-- , _saClientEmail :: !Text
272+-- , _saPrivateKeyId :: !Text
273+-- , _saPrivateKey :: !Text
276+-- instance FromJSON ServiceAccount where
277+-- parseJSON = withObject "service_account" $ \o -> ServiceAccount
278+-- <$> o .: "client_id"
279+-- <*> o .: "client_email"
280+-- <*> o .: "private_key_id"
281+-- <*> o .: "private_key"
283+data DefaultCredentials
284+ = User !AuthorizedUser
285+-- | Account !ServiceAccount
287+instance FromJSON DefaultCredentials where
288+ parseJSON = withObject "default_credentials" $ \o -> do
291+ "authorized_user" -> User <$> parseJSON (Object o)
292+ "service_account" -> fail "type: 'service_account' not supported."
293+ _ -> fail . Text.unpack $
294+ "Unrecognized default credentials type: " <> t
296+data Refresh a = Refresh
297+ { _rExpiry :: !UTCTime
298+ , _rToken :: !OAuthToken
302+isValid :: Refresh a -> IO Bool
304+ ts <- getCurrentTime
305+ pure $! ts < _rExpiry r
34− = Ref ThreadId (IORef AuthEnv)
308+ = Tok !OAuthToken
35− | Auth AuthEnv
309+ | Ref (MVar (Refresh AuthorizedUser))
36−
310+ (AuthorizedUser -> IO (Refresh AuthorizedUser))
37−withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a
312+withToken :: MonadIO m => Auth -> (OAuthToken -> m a) -> m a
38−withAuth (Ref _ r) f = liftIO (readIORef r) >>= f
313+withToken x f = refreshToken x >>= f
39−withAuth (Auth e) f = f e
314+
40−
315+refreshToken :: MonadIO m => Auth -> m OAuthToken
41−-- | Retrieve authentication information via the specified 'Credentials' mechanism.
316+refreshToken = liftIO . \case
42−getAuth :: Monad m => Credentials -> m Auth
317+ Tok t -> pure t
43−getAuth = \case
318+ Ref v f -> do
44− FromKey k -> pure $! Auth (AuthEnv (Left k) Nothing)
319+ x <- readMVar v
45− FromToken t -> pure $! Auth (AuthEnv (Right t) Nothing)
320+ xv <- isValid x
322+ then pure (_rToken x)
323+ else modifyMVar v $ \y -> do
326+ then pure (y, _rToken x)
332+ = FromToken !OAuthToken
333+ | FromFile !FilePath
337+getAuth :: MonadIO m => Manager -> Credentials -> m Auth
339+ FromToken t -> pure (Tok t)
340+ FromFile f -> undefined -- fromFilePath f
341+ Discover -> undefined
342+ -- catching _MissingFileError fromFile $ \f -> do
345+ -- throwingM _MissingFileError f
348+-- fromFile :: MonadIO m => m Auth
349+-- fromFile = undefined -- defaultCredentialsPath >>= fromFilePath
351+-- fromMetadata :: MonadIO m => Manager -> m Auth
352+-- fromMetadata m = liftIO $ do
354+-- Ref <$> newMVar r <*> pure refresh
357+-- bs <- httpLbs rq m
360+-- GOOGLE_AUTH_URI = 'https://accounts.google.com/o/oauth2/auth'
361+-- GOOGLE_DEVICE_URI = 'https://accounts.google.com/o/oauth2/device/code'
362+-- GOOGLE_REVOKE_URI = 'https://accounts.google.com/o/oauth2/revoke'
363+-- GOOGLE_TOKEN_URI = 'https://accounts.google.com/o/oauth2/token'
364+-- GOOGLE_TOKEN_INFO_URI = 'https://www.googleapis.com/oauth2/v2/tokeninfo'
366+-- fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth
367+-- fromFilePath m f = liftIO $ do
368+-- p <- doesFileExist f
370+-- throwM (MissingFileError f)
371+-- !u <- LBS.readFile f >>= either invalidErr pure . eitherDecode'
373+-- Ref <$> newMVar r <*> pure (refresh d)