@@ -1,4 +1,8 @@
1−{-# LANGUAGE LambdaCase #-}
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RecordWildCards #-}
26
37-- |
48-- Module : Network.Google.Auth
@@ -12,34 +16,358 @@
1216-- from the underlying OS.
1317module Network.Google.Auth where
1418
15−import Control.Concurrent (ThreadId)
19+import Control.Concurrent
20+import Control.Concurrent.MVar
21+import Control.Exception
22+import Control.Exception.Lens
23+import Control.Monad
24+import Control.Monad.Catch
1625import 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
34+import Data.Time
35+import Data.Typeable
1836import 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)
1945
20−data Credentials
21− = FromKey AuthKey
22− | FromToken OAuthToken
23− deriving (Eq)
24−
25−-- | The authorisation environment.
26−data AuthEnv = AuthEnv
27− { _authCreds :: Either AuthKey OAuthToken
28− , _authExpiry :: Maybe UTCTime
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
49+
50+-- -- | Retrieve authentication information via the specified 'Credentials' mechanism.
51+-- getAuth :: Monad m => Credentials -> m Auth
52+-- getAuth = \case
53+-- FromKey k -> pure $! Auth (AuthEnv (Left k) Nothing)
54+-- FromToken t -> pure $! Auth (AuthEnv (Right t) Nothing)
55+
56+
57+-- -- | Expiry is stored in RFC3339 UTC format
58+-- EXPIRY_FORMAT = "%Y-%m-%dT%H:%M:%SZ"
59+
60+-- -- | Which certs to use to validate id_tokens received.
61+-- ID_TOKEN_VERIFICATION_CERTS = "https://www.googleapis.com/oauth2/v1/certs"
62+
63+-- -- | Google Data client libraries may need to set this to [401, 403].
64+-- REFRESH_STATUS_CODES = [401]
65+
66+-- -- | The value representing user credentials.
67+-- AUTHORIZED_USER = "authorized_user"
68+
69+-- -- | The value representing service account credentials.
70+-- SERVICE_ACCOUNT = "service_account"
71+
72+-- -- | The environment variable pointing the file with local
73+-- -- Application Default Credentials.
74+-- GOOGLE_APPLICATION_CREDENTIALS = "GOOGLE_APPLICATION_CREDENTIALS"
75+
76+
77+-- _SERVER_SOFTWARE = 'SERVER_SOFTWARE'
78+-- _GCE_METADATA_HOST = '169.254.169.254'
79+-- _METADATA_FLAVOR_HEADER = 'Metadata-Flavor'
80+-- _DESIRED_METADATA_FLAVOR = 'Google'
81+
82+-- NO_GCE_CHECK = os.environ.setdefault('NO_GCE_CHECK', 'False')
83+
84+-- # The error message we show users when we can't find the Application
85+-- # Default Credentials.
86+-- ADC_HELP_MSG = (
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.')
94+
95+-- # The access token along with the seconds in which it expires.
96+-- AccessTokenInfo = collections.namedtuple(
97+-- 'AccessTokenInfo', ['access_token', 'expires_in'])
98+
99+-- DEFAULT_ENV_NAME = 'UNKNOWN'
100+
101+detectGCE :: MonadIO m => Manager -> m Bool
102+detectGCE m = pure False
103+
104+-- def _detect_gce_environment():
105+-- """Determine if the current environment is Compute Engine.
106+-- Returns:
107+-- Boolean indicating whether or not the current environment is Google
108+-- Compute Engine.
109+-- """
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
115+-- # "unlikely".
116+-- connection = six.moves.http_client.HTTPConnection(
117+-- _GCE_METADATA_HOST, timeout=1)
118+
119+-- try:
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.')
128+-- return False
129+-- finally:
130+-- connection.close()
131+
132+isGAE :: MonadIO m => m Bool
133+isGAE = pure False
134+ -- if SETTINGS.env_name is not None:
135+ -- return SETTINGS.env_name in ('GAE_PRODUCTION', 'GAE_LOCAL')
136+
137+ -- try:
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'
142+ -- return True
143+ -- elif server_software.startswith('Development/'):
144+ -- SETTINGS.env_name = 'GAE_LOCAL'
145+ -- return True
146+ -- except ImportError:
147+ -- pass
148+
149+ -- return False
150+
151+isGCE :: MonadIO m => m Bool
152+isGCE = pure False
153+-- def _in_gce_environment():
154+-- """Detect if the code is running in the Compute Engine environment.
155+-- Returns:
156+-- True if running in the GCE environment, False otherwise.
157+-- """
158+-- if SETTINGS.env_name is not None:
159+-- return SETTINGS.env_name == 'GCE_PRODUCTION'
160+
161+-- if NO_GCE_CHECK != 'True' and _detect_gce_environment():
162+-- SETTINGS.env_name = 'GCE_PRODUCTION'
163+-- return True
164+-- return False
165+
166+newtype ClientId = ClientId { clientId :: Text }
167+ deriving (Eq, Show, FromJSON, ToJSON)
168+
169+data AuthError
170+ = RetrievalError HttpException
171+ | MissingFileError FilePath
172+ | InvalidFileError FilePath Text
173+ | TokenRefreshError Status ClientId Text (Maybe Text)
174+ deriving (Show, Typeable)
175+
176+instance Exception AuthError
177+
178+parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
179+parseLBS = either (Left . Text.pack) Right . eitherDecode'
180+
181+-- | The environment variable name which can replace ~/.config if set.
182+cloudSDKConfigDirVar = "CLOUDSDK_CONFIG"
183+cloudSDKConfigDir = "gcloud"
184+cloudSDKConfigFile = "application_default_credentials.json"
185+
186+defaultCredentialsPath :: MonadIO m => m FilePath
187+defaultCredentialsPath = liftIO $ do
188+ v <- lookupEnv cloudSDKConfigDirVar
189+ h <- getHomeDirectory
190+ let d = case v of
191+ Nothing | os == "windows" -> h </> cloudSDKConfigDir
192+ Nothing -> h </> ".config" </> cloudSDKConfigDir
193+ Just x -> h </> x
194+ pure $! d </> cloudSDKConfigFile
195+
196+data AuthorizedUser = AuthorizedUser
197+ { _auClientId :: !ClientId
198+ , _auClientSecret :: !Text
199+ , _auRefreshToken :: !Text
200+ }
201+
202+instance FromJSON AuthorizedUser where
203+ parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser
204+ <$> o .: "client_id"
205+ <*> o .: "client_secret"
206+ <*> o .: "refresh_token"
207+
208+data AuthorizedRefresh = AuthorizedRefresh
209+ { _arAccessToken :: !OAuthToken
210+ , _arRefreshToken :: !(Maybe Text)
211+ , _arExpiresIn :: !NominalDiffTime
29212 }
30213
31−-- | An authorisation environment containing Google credentials, and potentially
32−-- a reference which can be refreshed out-of-band as credentials expire.
214+instance FromJSON AuthorizedRefresh where
215+ parseJSON = withObject "authorized_refresh" $ \o -> AuthorizedRefresh
216+ <$> o .: "access_token"
217+ <*> o .:? "refresh_token"
218+ <*> (fromInteger <$> o .: "expires_in")
219+
220+data AuthorizedError = AuthorizedError
221+ { _aeError :: !Text
222+ , _aeDescription :: !(Maybe Text)
223+ }
224+
225+instance FromJSON AuthorizedError where
226+ parseJSON = withObject "authorized_error" $ \o -> AuthorizedError
227+ <$> o .: "error"
228+ <*> o .:? "error_description"
229+
230+refreshUser :: Manager -> AuthorizedUser -> IO (Refresh AuthorizedUser)
231+refreshUser m u@AuthorizedUser {..} = do
232+ rs <- httpLbs rq m
233+ let bs = responseBody rs
234+ s = responseStatus rs
235+ if fromEnum s == 200 then success s bs else failure s bs
236+ where
237+ failure s bs = do
238+ AuthorizedError {..} <- parseErr s bs
239+ refreshErr s _aeError _aeDescription
240+
241+ success s bs = do
242+ AuthorizedRefresh {..} <- parseErr s bs
243+ ts <- getCurrentTime
244+ pure $! Refresh (addUTCTime _arExpiresIn ts) _arAccessToken $
245+ u { _auRefreshToken = fromMaybe _auRefreshToken _arRefreshToken }
246+
247+ parseErr s bs =
248+ case parseLBS bs of
249+ Left e -> refreshErr s e Nothing
250+ Right x -> pure x
251+
252+ refreshErr s e = throwM . TokenRefreshError s _auClientId e
253+
254+ rq = def
255+ { Client.host = "accounts.google.com"
256+ , Client.port = 443
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
267+ }
268+
269+-- data ServiceAccount = ServiceAccount
270+-- { _saClientId :: !Text
271+-- , _saClientEmail :: !Text
272+-- , _saPrivateKeyId :: !Text
273+-- , _saPrivateKey :: !Text
274+-- }
275+
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"
282+
283+data DefaultCredentials
284+ = User !AuthorizedUser
285+-- | Account !ServiceAccount
286+
287+instance FromJSON DefaultCredentials where
288+ parseJSON = withObject "default_credentials" $ \o -> do
289+ t <- o .: "type"
290+ case t of
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
295+
296+data Refresh a = Refresh
297+ { _rExpiry :: !UTCTime
298+ , _rToken :: !OAuthToken
299+ , _rTarget :: !a
300+ }
301+
302+isValid :: Refresh a -> IO Bool
303+isValid r = do
304+ ts <- getCurrentTime
305+ pure $! ts < _rExpiry r
306+
33307data Auth
34− = Ref ThreadId (IORef AuthEnv)
35− | Auth AuthEnv
36−
37−withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a
38−withAuth (Ref _ r) f = liftIO (readIORef r) >>= f
39−withAuth (Auth e) f = f e
40−
41−-- | Retrieve authentication information via the specified 'Credentials' mechanism.
42−getAuth :: Monad m => Credentials -> m Auth
43−getAuth = \case
44− FromKey k -> pure $! Auth (AuthEnv (Left k) Nothing)
45− FromToken t -> pure $! Auth (AuthEnv (Right t) Nothing)
308+ = Tok !OAuthToken
309+ | Ref (MVar (Refresh AuthorizedUser))
310+ (AuthorizedUser -> IO (Refresh AuthorizedUser))
311+
312+withToken :: MonadIO m => Auth -> (OAuthToken -> m a) -> m a
313+withToken x f = refreshToken x >>= f
314+
315+refreshToken :: MonadIO m => Auth -> m OAuthToken
316+refreshToken = liftIO . \case
317+ Tok t -> pure t
318+ Ref v f -> do
319+ x <- readMVar v
320+ xv <- isValid x
321+ if xv
322+ then pure (_rToken x)
323+ else modifyMVar v $ \y -> do
324+ yv <- isValid y
325+ if yv
326+ then pure (y, _rToken x)
327+ else do
328+ z <- f (_rTarget y)
329+ pure (z, _rToken z)
330+
331+data Credentials
332+ = FromToken !OAuthToken
333+ | FromFile !FilePath
334+ | Discover
335+ deriving (Eq, Show)
336+
337+getAuth :: MonadIO m => Manager -> Credentials -> m Auth
338+getAuth m = \case
339+ FromToken t -> pure (Tok t)
340+ FromFile f -> undefined -- fromFilePath f
341+ Discover -> undefined
342+ -- catching _MissingFileError fromFile $ \f -> do
343+ -- p <- detectGCE m
344+ -- unless p $
345+ -- throwingM _MissingFileError f
346+ -- fromMetadata m
347+
348+-- fromFile :: MonadIO m => m Auth
349+-- fromFile = undefined -- defaultCredentialsPath >>= fromFilePath
350+
351+-- fromMetadata :: MonadIO m => Manager -> m Auth
352+-- fromMetadata m = liftIO $ do
353+-- !r <- refresh
354+-- Ref <$> newMVar r <*> pure refresh
355+-- where
356+-- refresh = do
357+-- bs <- httpLbs rq m
358+-- parseLBS
359+
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'
365+
366+-- fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth
367+-- fromFilePath m f = liftIO $ do
368+-- p <- doesFileExist f
369+-- unless p $
370+-- throwM (MissingFileError f)
371+-- !u <- LBS.readFile f >>= either invalidErr pure . eitherDecode'
372+-- !r <- refresh m u
373+-- Ref <$> newMVar r <*> pure (refresh d)