git.iko.soy/gogol
on develop help sign in
Expanding authentication primitives with Installed Application Flow
69af7a4Brendan Hay
core/src/Network/Google/Types.hs+16−37
compare with develop
unifiedsplit
@@ -55,47 +55,32 @@ import Network.HTTP.Types hiding (Header)
55import qualified Network.HTTP.Types as HTTP
55import qualified Network.HTTP.Types as HTTP
56import Servant.API
56import Servant.API
57
57
58−data AltJSON = AltJSON
58+data AltJSON = AltJSON deriving (Eq, Ord, Show, Read, Generic, Typeable)
59− deriving (Eq, Ord, Show, Read, Generic, Typeable)
59+data AltMedia = AltMedia deriving (Eq, Ord, Show, Read, Generic, Typeable)
60
60
61−instance ToText AltJSON where
61+instance ToText AltJSON where toText = const "json"
62− toText = const "json"
63−
64−data AltMedia = AltMedia
65− deriving (Eq, Ord, Show, Read, Generic, Typeable)
66−
67−instance ToText AltMedia where
62+instance ToText AltMedia where toText = const "media"
68− toText = const "media"
69−
70−newtype AuthKey = AuthKey Text
71− deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)
72
63
73newtype OAuthScope = OAuthScope { scopeToText :: Text }
64newtype OAuthScope = OAuthScope { scopeToText :: Text }
74− deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
65+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
75−
76−concatScopes :: [OAuthScope] -> OAuthScope
77−concatScopes = OAuthScope
78− . Text.intercalate " "
79− . (coerce :: [OAuthScope] -> [Text])
80
66
81−newtype OAuthToken = OAuthToken { tokenToBS :: ByteString }
67+newtype AccessToken = AccessToken { accessToText :: Text }
82− deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable)
68+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
83
69
84−instance FromJSON OAuthToken where
70+newtype RefreshToken = RefreshToken { refreshToText :: Text }
85− parseJSON = withText "oauth_token" (pure . OAuthToken . Text.encodeUtf8)
71+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
86
72
87−instance ToJSON OAuthToken where
73+newtype ClientId = ClientId { clientIdToText :: Text }
88− toJSON = toJSON . Text.decodeUtf8 . tokenToBS
74+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
89
75
90−instance FromText OAuthToken where
76+newtype Secret = Secret { secretToText :: Text }
91− fromText = Just . OAuthToken . Text.encodeUtf8
77+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
92
78
93−instance ToText OAuthToken where
79+newtype ServiceId = ServiceId { serviceIdToText :: Text }
94− toText = Text.decodeUtf8 . tokenToBS
80+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
95
81
96newtype MediaDownload a = MediaDownload a
82newtype MediaDownload a = MediaDownload a
97−
98−data MediaUpload a = MediaUpload a RequestBody
83+data MediaUpload a = MediaUpload a RequestBody
99
84
100_Coerce :: (Coercible a b, Coercible b a) => Iso' a b
85_Coerce :: (Coercible a b, Coercible b a) => Iso' a b
101_Coerce = iso coerce coerce
86_Coerce = iso coerce coerce
@@ -110,12 +95,6 @@ _Default = iso f Just
110
95
111type Stream = ResumableSource (ResourceT IO) ByteString
96type Stream = ResumableSource (ResourceT IO) ByteString
112
97
113−newtype ClientId = ClientId { clientIdToText :: Text }
114− deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
115−
116−newtype ServiceId = ServiceId { serviceIdToText :: Text }
117− deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
118−
119data Error
98data Error
120 = TransportError HttpException
99 = TransportError HttpException
121 | SerializeError SerializeError
100 | SerializeError SerializeError
gogol/src/Network/Google/Auth.hs+497−341
@@ -1,5 +1,6 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
@@ -18,57 +19,61 @@
18--
19--
19-- Explicitly specify your Google credentials, or retrieve them
20-- Explicitly specify your Google credentials, or retrieve them
20-- from the underlying OS.
21-- from the underlying OS.
21−module Network.Google.Auth
22+module Network.Google.Auth where
22− (
23+ -- (
23− -- * Authentication
24+ -- -- * Authentication
24− -- ** Retrieving Authentication
25+ -- -- ** Retrieving Authentication
25− getAuth
26+ -- getAuth
26− , Credentials (..)
27+ -- , Credentials (..)
27− , Auth
28+ -- , Auth
28−
29+
29− -- ** Authorising Requests
30+ -- -- ** Authorising Requests
30− , authorise
31+ -- , authorize
31−
32+
32− -- ** Default Constants
33+ -- -- ** Default Constants
33− -- *** Google Compute Engine
34+ -- -- *** Google Compute Engine
34− , checkGCEVar
35+ -- , checkGCEVar
35−
36+
36− -- *** Cloud SDK
37+ -- -- *** Cloud SDK
37− , cloudSDKConfigDir
38+ -- , cloudSDKConfigDir
38− , cloudSDKConfigPath
39+ -- , cloudSDKConfigPath
39−
40+
40− -- *** Application Default Credentials
41+ -- -- *** Application Default Credentials
41− , defaultCredentialsFile
42+ -- , defaultCredentialsFile
42− , defaultCredentialsPath
43+ -- , defaultCredentialsPath
43−
44+
44− -- ** Credentials
45+ -- -- ** Credential Styles
45− , fromMetadata
46+ -- , fromMetadata
46− , fromFile
47+ -- , fromFile
47− , fromFilePath
48+ -- , fromFilePath
48−
49+
49− -- *** Authorised User
50+ -- -- *** OAuth Token
50− , AuthorisedUser (..)
51+ -- , Bearer (..)
51− , fromAuthorisedUser
52+ -- , fromToken
52−
53+
54+ -- -- *** Authorized User
55+ -- , AuthorizedUser (..)
56+ -- , fromAuthorizedUser
57+
53− -- *** Service Account
58+ -- -- *** Service Account
54− , ServiceAccount (..)
59+ -- , ServiceAccount (..)
55− , fromServiceAccount
60+ -- , fromServiceAccount
56−
61+
57− -- ** Handling Errors
62+ -- -- ** Handling Errors
58− , AsAuthError (..)
63+ -- , AsAuthError (..)
59− , AuthError (..)
64+ -- , AuthError (..)
60−
65+
61− -- ** Re-exported Types
66+ -- -- ** Re-exported Types
62− , OAuthScope (..)
67+ -- , Scope (..)
63− , OAuthToken (..)
68+ -- , OAuthToken (..)
64− , ServiceId (..)
69+ -- , ServiceId (..)
65− , ClientId (..)
70+ -- , ClientId (..)
66− ) where
71+ -- ) where
67
72
68import Control.Applicative
73import Control.Applicative
69import Control.Concurrent
74import Control.Concurrent
70import Control.Exception.Lens
75import Control.Exception.Lens
71−import Control.Lens hiding ((.=))
76+import Control.Lens hiding (coerce, (.=))
72import Control.Monad
77import Control.Monad
73import Control.Monad.Catch
78import Control.Monad.Catch
74import Control.Monad.IO.Class
79import Control.Monad.IO.Class
@@ -80,11 +85,19 @@ import Data.Aeson.Types
80import Data.ByteArray
85import Data.ByteArray
81import Data.ByteArray.Encoding
86import Data.ByteArray.Encoding
82import Data.ByteString (ByteString)
87import Data.ByteString (ByteString)
88+import Data.ByteString.Builder (Builder)
89+import qualified Data.ByteString.Builder as Build
83import qualified Data.ByteString.Char8 as BS8
90import qualified Data.ByteString.Char8 as BS8
84import qualified Data.ByteString.Lazy as LBS
91import qualified Data.ByteString.Lazy as LBS
92+import Data.Coerce
85import Data.Default.Class (def)
93import Data.Default.Class (def)
94+import Data.List (intersperse)
95+import Data.String
86import qualified Data.Text as Text
96import qualified Data.Text as Text
87import qualified Data.Text.Encoding as Text
97import qualified Data.Text.Encoding as Text
98+import qualified Data.Text.Lazy as LText
99+import qualified Data.Text.Lazy.Builder as TBuild
100+import qualified Data.Text.Lazy.Encoding as LText
88import Data.Time
101import Data.Time
89import Data.Time.Clock.POSIX
102import Data.Time.Clock.POSIX
90import Data.Typeable
103import Data.Typeable
@@ -92,7 +105,7 @@ import Data.X509
92import Data.X509.Memory
105import Data.X509.Memory
93import Network.Google.Compute.Metadata
106import Network.Google.Compute.Metadata
94import Network.Google.Internal.Logger
107import Network.Google.Internal.Logger
95−import Network.Google.Prelude
108+import Network.Google.Prelude hiding (buildText)
96import Network.HTTP.Conduit hiding (Request)
109import Network.HTTP.Conduit hiding (Request)
97import qualified Network.HTTP.Conduit as Client
110import qualified Network.HTTP.Conduit as Client
98import Network.HTTP.Types
111import Network.HTTP.Types
@@ -177,135 +190,6 @@ instance AsAuthError AuthError where
177 TokenRefreshError s e d -> Right (s, e, d)
190 TokenRefreshError s e d -> Right (s, e, d)
178 x -> Left x)
191 x -> Left x)
179
192
180−-- | Determines how AuthN/AuthZ information is retrieved.
181−data Credentials
182− = FromToken !OAuthToken
183− -- ^ Supply an explicit access token. See 'fromToken'.
184−
185− | FromFile !FilePath
186− -- ^ Load the Application Default Credentials from a specific file path.
187− -- The file can be formatted as either a @service_account@ or an @authorized_user@.
188−
189− | FromAccount !ServiceId
190− -- ^ Retrieve the Application Default Credentials using the speicfic
191− -- 'ServiceId' from the local metadata endpoint.
192−
193− | Discover
194− -- ^ Attempt credentials discovery via the following steps:
195− --
196− -- * Read the default credentials from a file specified by
197− -- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists.
198− --
199− -- * Read the platform equivalent of @~\/.config\/gcloud\/application_default_credentials.json@ if it exists.
200− -- The @~/.config@ component of the path can be overriden by the environment
201− -- variable @CLOUDSDK_CONFIG@ if it exists.
202− --
203− -- * Retrieve the default service account application credentials if
204− -- running on GCE.
205− deriving (Eq, Show)
206−
207−-- | Retrieve authentication information via the specified 'Credentials' mechanism.
208−--
209−-- The specified 'OAuthScope's are used to authorise any @service_account@
210−-- with the appropriate scopes. See the top-level module of each individual
211−-- @gogol-*@ library for a list of available scopes, such as @Network.Google.Compute.computeScope@.
212−--
213−-- Throws 'AuthError' when environment variables or service account information
214−-- cannot be read, and credentials files are invalid or cannot be found.
215−getAuth :: (MonadIO m, MonadCatch m)
216− => Credentials
217− -> [OAuthScope]
218− -> Logger
219− -> Manager
220− -> m Auth
221−getAuth c ss l m = case c of
222− FromToken t -> pure (AuthToken t)
223− FromFile f -> fromFilePath ss f l m
224− FromAccount s -> fromMetadata s l m
225− Discover ->
226− catching _MissingFileError (fromFile ss l m) $ \f -> do
227− p <- isGCE m
228− unless p $
229− throwingM _MissingFileError f
230− fromMetadata "default" l m
231−
232−-- | Refresh a token from the local GCE metadata endpoint for the specified
233−-- 'ServiceId'.
234−fromMetadata :: (MonadIO m, MonadCatch m)
235− => ServiceId
236− -> Logger
237− -> Manager
238− -> m Auth
239−fromMetadata s l = refresh s l >=> fmap AuthMeta . liftIO . newMVar
240−
241−-- | Attempt to load either a @service_account@ or @authorized_user@ formatted
242−-- file to obtain the credentials neccessary to perform a token refresh.
243−fromFile :: (MonadIO m, MonadCatch m) => [OAuthScope] -> Logger -> Manager -> m Auth
244−fromFile ss l m = do
245− f <- defaultCredentialsPath
246− case f of
247− Just x -> fromFilePath ss x l m
248− Nothing -> do
249− x <- cloudSDKConfigPath
250− fromFilePath ss x l m
251−
252−-- | An internal type inhabited by the supported JSON formats
253−-- for Application Default Credentials.
254−data AccountJSON
255− = ParsedService !ServiceAccount
256− | ParsedUser !AuthorisedUser
257−
258−-- The following instance accumulates all error messages if all parsers fail.
259−-- If there is a success, the entire parse succeeds with the single
260−-- successful parse.
261−instance FromJSON AccountJSON where
262− parseJSON o =
263− let x = ParsedService <$> parseEither parseJSON o
264− y = ParsedUser <$> parseEither parseJSON o
265− in either fail pure $
266− case (x, y) of
267− (Left e, Left e') -> Left $
268− "Failed parsing service_account: " ++ e ++
269− ", Failed parsing authorized_user: " ++ e'
270− _ -> x <|> y
271−
272−-- | Attempt to load either a @service_account@ or @authorized_user@ formatted
273−-- file to obtain the credentials neccessary to perform a token refresh from
274−-- the specified file.
275−fromFilePath :: (MonadIO m, MonadCatch m)
276− => [OAuthScope]
277− -> FilePath
278− -> Logger
279− -> Manager
280− -> m Auth
281−fromFilePath ss f l m = do
282− logDebug l $ "Trying to read credentials from " <> build f
283− p <- liftIO (doesFileExist f)
284− unless p $
285− throwM (MissingFileError f)
286− e <- liftIO (LBS.readFile f) >>=
287− either (throwM . InvalidFileError f) pure . parseLBS
288− case e of
289− ParsedUser u -> fromAuthorisedUser u l m
290− ParsedService a -> fromServiceAccount (a { _serviceScope = ss }) l m
291−
292−fromAuthorisedUser :: (MonadIO m, MonadCatch m)
293− => AuthorisedUser
294− -> Logger
295− -> Manager
296− -> m Auth
297−fromAuthorisedUser u l m =
298− refresh u l m >>= fmap AuthUser . liftIO . newMVar
299−
300−fromServiceAccount :: (MonadIO m, MonadCatch m)
301− => ServiceAccount
302− -> Logger
303− -> Manager
304− -> m Auth
305−fromServiceAccount s l m =
306− -- Add a check to ensure scopes aren't empty.
307− refresh s l m >>= fmap AuthSign . liftIO . newMVar
308−
309-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
193-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
310-- default application credentials filepath.
194-- default application credentials filepath.
311defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
195defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
@@ -339,160 +223,425 @@ instance FromJSON RefreshError where
339 <$> o .: "error"
223 <$> o .: "error"
340 <*> o .:? "error_description"
224 <*> o .:? "error_description"
341
225
342−data Expires a = Expires
226+{-| Service Account credentials which are typically generated/download
343− { _expiry :: !UTCTime
227+from the Google Developer console of the following form:
344− , _token :: !OAuthToken
228+
345− , _details :: !a
229+@
346− }
230+{
231+ "type": "service_account",
232+ "private_key_id": "303ad77e5efdf2ce952DFa",
233+ "private_key": "-----BEGIN PRIVATE KEY-----\n...\n",
234+ "client_email": "email@serviceaccount.com",
235+ "client_id": "035-2-310.useraccount.com"
236+}
237+@
238+
239+The private key is used to sign a JSON Web Token (JWT) of the
240+grant_type @urn:ietf:params:oauth:grant-type:jwt-bearer@, which is sent to
241+'accountsURL' to obtain a valid 'OAuthToken'. This process requires explicitly
242+specifying which 'Scope's the resulting 'OAuthToken' is authorized to access.
243+
244+A 'ServiceAccount' is typically generated through the
245+Google Developer Console.
246+-}
247+data ServiceAccount = ServiceAccount
248+ { _serviceId :: !ClientId
249+ , _serviceEmail :: !Text
250+ , _serviceKeyId :: !Text
251+ , _servicePrivateKey :: !PrivateKey
252+ } deriving (Eq, Show)
347
253
348−isValid :: MonadIO m => Expires a -> m Bool
254+instance FromJSON ServiceAccount where
349−isValid r = (< _expiry r) <$> liftIO getCurrentTime
255+ parseJSON = withObject "service_account" $ \o -> do
256+ bs <- Text.encodeUtf8 <$> o .: "private_key"
257+ k <- case listToMaybe (readKeyFileFromMemory bs) of
258+ Just (PrivKeyRSA k) -> pure k
259+ _ ->
260+ fail "Unable to parse key contents from \"private_key\""
261+ ServiceAccount
262+ <$> o .: "client_id"
263+ <*> o .: "client_email"
264+ <*> o .: "private_key_id"
265+ <*> pure k
350
266
351−data Auth
267+{-| Authorized User credentials which are typically generated by the Cloud SDK
352− = AuthToken !OAuthToken
268+tools such as @gcloud init@, of the following form:
353− | AuthSign !(MVar (Expires ServiceAccount))
354− | AuthMeta !(MVar (Expires ServiceId))
355− | AuthUser !(MVar (Expires AuthorisedUser))
356
269
357−authorise :: (MonadIO m, MonadCatch m)
270+{
358− => Logger
271+ "type": "authorized_user",
359− -> Manager
272+ "client_id": "32555940559.apps.googleusercontent.com",
360− -> Client.Request
273+ "client_secret": "Zms2qjJy2998hD4CTg2ejr2",
361− -> Auth
274+ "refresh_token": "1/B3gM1x35v.VtqffS1n5w-rSJ"
362− -> m Client.Request
363−authorise l m rq = \case
364− AuthToken t -> pure $! authoriseBearer rq t
365− AuthSign r -> authoriseToken l m r rq
366− AuthMeta r -> authoriseToken l m r rq
367− AuthUser r -> authoriseToken l m r rq
368−
369−authoriseBearer :: Client.Request -> OAuthToken -> Client.Request
370−authoriseBearer rq t = rq
371− { Client.requestHeaders = (hAuthorization, "Bearer " <> tokenToBS t)
372− : Client.requestHeaders rq
373− }
275+}
374
276
375−authoriseToken :: (MonadIO m, MonadCatch m, Refresh a)
277+The secret and refresh token are used to obtain a valid 'OAuthToken' from
376− => Logger
278+'accountsURL' using grant_type @refresh_token@.
377− -> Manager
378− -> MVar (Expires a)
379− -> Client.Request
380− -> m Client.Request
381−authoriseToken l m r rq = authoriseBearer rq <$> refreshToken l m r
382
279
383−refreshToken :: (MonadIO m, MonadCatch m, Refresh a)
280+An 'AuthorizedUser' is typically generated by the @gcloud init@ command
384− => Logger
281+of the Google CloudSDK Tools.
385− -> Manager
282+-}
386− -> MVar (Expires a)
283+data AuthorizedUser = AuthorizedUser
387− -> m OAuthToken
284+ { _userId :: !ClientId
388−refreshToken l m r = do
285+ , _userRefresh :: !RefreshToken
389− x <- liftIO (readMVar r)
286+ , _userSecret :: !Secret
390− xv <- isValid x
287+ } deriving (Eq, Show)
391− if xv
288+
392− then pure (_token x)
289+instance FromJSON AuthorizedUser where
393− else liftIO . modifyMVar r $ \y -> do
290+ parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser
394− yv <- isValid y
291+ <$> o .: "client_id"
395− if yv
396− then pure (y, _token y)
397− else do
398− z <- refresh (_details y) l m
399− pure (z, _token z)
400−
401−-- {
402−-- "access_token": "sadsdasd",
403−-- "expires_in": 3600,
404−-- "id_token": "eyJhbGciOiJSd",
405−-- "refresh_token": "1/B3gq9K",
292+ <*> o .: "refresh_token"
406−-- "token_type": "Bearer"
293+ <*> o .: "client_secret"
407−-- }
408−
409−data Bearer = Bearer
410− { _bearerAccess :: !OAuthToken
411− , _bearerRefresh :: !(Maybe Text)
412− , _bearerExpiry :: !UTCTime
413− }
414
294
295+-- | A client identifier and accompanying secret used to obtain/refresh a token.
296+data OAuthClient = OAuthClient
297+ { _clientId :: !ClientId
298+ , _clientSecret :: !Secret
299+ } deriving (Eq, Show)
300+
301+{-| An OAuth bearer type token of the following form:
302+
303+@
304+{
305+ "token_type": "Bearer",
306+ "access_token": "eyJhbGci...",
307+ "refresh_token": "1/B3gq9K...",
308+ "expires_in": 3600,
309+ ...
310+}
311+@
312+
313+The '_tokenAccess' field will be inserted verbatim into the
314+@Authorization: Bearer ...@ header for all HTTP requests.
315+-}
316+data OAuthToken = OAuthToken
317+ { _tokenAccess :: !AccessToken
318+ , _tokenRefresh :: !(Maybe RefreshToken)
319+ , _tokenExpiry :: !UTCTime
320+ } deriving (Eq, Show)
321+
415−instance FromJSON (UTCTime -> Bearer) where
322+instance FromJSON (UTCTime -> OAuthToken) where
416 parseJSON = withObject "bearer" $ \o -> do
323 parseJSON = withObject "bearer" $ \o -> do
417 t <- o .: "access_token"
324 t <- o .: "access_token"
418 r <- o .:? "refresh_token"
325 r <- o .:? "refresh_token"
419 e <- o .: "expires_in" <&> fromInteger
326 e <- o .: "expires_in" <&> fromInteger
420− pure (Bearer t r . addUTCTime e)
327+ pure (OAuthToken t r . addUTCTime e)
421
328
422−-- {
329+newtype OAuthCode = OAuthCode { codeToText :: Text }
423−-- "private_key_id": "303ad77e5efdf2ce952DFa",
330+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
424−-- "private_key": "-----BEGIN PRIVATE KEY-----\nMIIE...\n",
425−-- "client_email": "01395191@gserviceaccount.com",
426−-- "client_id": "035-2-310eusercontent.com",
427−-- "type": "service_account"
428−-- }
429
331
430−data ServiceAccount = ServiceAccount
332+-- | The supported credential mechanisms.
431− { _serviceId :: !ClientId
333+data Credentials
432− , _serviceEmail :: !Text
334+ = FromMetadata !ServiceId
433− , _serviceScope :: ![OAuthScope]
335+ -- ^ Obtain and refresh access tokens from the underlying GCE host metadata
434− , _serviceKeyId :: !Text
336+ -- at @http:\/\/169.254.169.254@.
435− , _serviceKey :: !PrivateKey
436− }
437
337
438−instance FromJSON ServiceAccount where
338+ | FromClient !OAuthClient !OAuthCode
439− parseJSON = withObject "service_account" $ \o -> do
339+ -- ^ Obtain and refresh access tokens using the specified client secret
440− bs <- Text.encodeUtf8 <$> o .: "private_key"
340+ -- and authorization code obtained from.
441− ServiceAccount
341+ --
442− <$> o .: "client_id"
342+ -- See the <https://developers.google.com/accounts/docs/OAuth2InstalledApp OAuth2 Installed Application>
443− <*> o .: "client_email"
343+ -- documentation for more information.
444− <*> pure mempty
445− <*> o .: "private_key_id"
446− <*> case listToMaybe (readKeyFileFromMemory bs) of
447− Just (PrivKeyRSA k) -> pure k
448− _ ->
449− fail "Unable to parse key contents from \"private_key\""
450−
451−-- {
452−-- "client_id": "32555940559.apps.googleusercontent.com",
453−-- "client_secret": "ZmssLNjJy2998hD4CTg2ejr2",
454−-- "refresh_token": "1/B3gqKM1xzVtqffS1n5w-rSJ",
455−-- "type": "authorized_user"
456−-- }
457−
458−data AuthorisedUser = AuthorisedUser
459− { _userId :: !ClientId
460− , _userSecret :: !Text
461− , _userRefresh :: !Text
462− }
463
344
464−instance FromJSON AuthorisedUser where
345+ | FromAccount !ServiceAccount ![OAuthScope]
465− parseJSON = withObject "authorized_user" $ \o -> AuthorisedUser
346+ -- ^ Use the specified @service_account@ and scopes to sign and request
466− <$> o .: "client_id"
347+ -- an access token. The 'ServiceAccount' will also be used for subsequent
467− <*> o .: "client_secret"
348+ -- token refreshes.
468− <*> o .: "refresh_token"
349+ --
350+ -- A 'ServiceAccount' is typically generated through the
351+ -- Google Developer Console.
352+
353+ | FromUser !AuthorizedUser
354+ -- ^ Use the specified @authorized_user@ to obtain and refresh access tokens.
355+ --
356+ -- An 'AuthorizedUser' is typically created by the @gcloud init@ command
357+ -- of the Google CloudSDK Tools.
358+
359+-- | A credentials value in one of two possible states, pre-exchange and
360+-- containing a valid, but possibly expired access token.
361+data Auth
362+ = Exchange !Credentials
363+ -- ^ Signifies that the initial token refresh has not occured, and the
364+ -- 'Credentials' need to be signed and exchanged for a valid 'OAuthToken'.
365+
366+ | Refresh !Credentials !OAuthToken
367+ -- ^ An 'OAuthToken' that can potentially be expired, with the original
368+ -- credentials that can be used to perform a refresh.
369+
370+type Store = MVar Auth
371+
372+emptyStore :: MonadIO m => Credentials -> m Store
373+emptyStore !c = liftIO . newMVar $ Exchange c
469
374
470−class Refresh a where
375+-- FIXME: support for generating the url using scopes to obtain the OAuthCode.
376+
377+-- FIXME:
378+-- The parameter is include_granted_scopes and the allowed values are true and
379+-- false (the default is false). When the value is true, the effect is that if
380+-- your scope authorization request is granted, the Google authorization server
381+-- will roll this authorization together with all the previous authorizations
382+-- granted to the requesting user from the requesting app.
383+
384+-- FIXME: Get around to replacing the threading of Logger, Manager through
385+-- every exchange/refresh call.
386+
387+-- | Retrieve authentication information via the specified 'Credentials' mechanism.
388+--
389+--
390+-- Throws 'AuthError' when environment variables or service account information
391+-- cannot be read, and credentials files are invalid or cannot be found.
392+-- getAuth :: (MonadIO m, MonadCatch m)
393+-- => Credentials
394+-- -> [Scope]
395+-- -> Logger
396+-- -> Manager
397+-- -> m Auth
398+-- getAuth c ss l m = case c of
399+-- FromToken t -> pure (AuthToken t)
400+-- FromFile f -> fromFilePath ss f l m
401+-- FromAccount s -> fromMetadata s l m
402+-- Discover ->
403+-- catching _MissingFileError (fromFile ss l m) $ \f -> do
404+-- p <- isGCE m
405+-- unless p $
406+-- throwingM _MissingFileError f
407+-- fromMetadata "default" l m
408+
409+-- | Attempt credentials discovery via the following steps:
410+--
411+-- * Read the default credentials from a file specified by
412+-- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists.
413+--
414+-- * Read the platform equivalent of @~\/.config\/gcloud\/application_default_credentials.json@ if it exists.
415+-- The @~/.config@ component of the path can be overriden by the environment
416+-- variable @CLOUDSDK_CONFIG@ if it exists.
417+--
418+-- * Retrieve the default service account application credentials if
419+-- running on GCE.
420+--
421+-- The specified 'Scope's are used to authorize any @service_account@ that is
422+-- found with the appropriate scopes, otherwise they are not used. See the
423+-- top-level module of each individual @gogol-*@ library for a list of available
424+-- scopes, such as @Network.Google.Compute.computeScope@.
425+discover :: (MonadIO m, MonadCatch m)
426+ => [OAuthScope]
427+ -> Manager
428+ -> m Credentials
429+discover ss m =
430+ catching _MissingFileError (fromFile ss) $ \f -> do
431+ p <- isGCE m
432+ unless p $
433+ throwingM _MissingFileError f
434+ pure $! FromMetadata "default"
435+
436+-- | Attempt to load either a @service_account@ or @authorized_user@ formatted
437+-- file to obtain the credentials neccessary to perform a token refresh.
438+--
439+-- The specified 'Scope's are used to authorize any @service_account@ that is
440+-- found with the appropriate scopes, otherwise they are not used. See the
441+-- top-level module of each individual @gogol-*@ library for a list of available
442+-- scopes, such as @Network.Google.Compute.computeScope@.
443+--
444+-- /See:/ 'cloudSDKConfigPath', 'defaultCredentialsPath'.
471− refresh :: (MonadIO m, MonadCatch m)
445+fromFile :: (MonadIO m, MonadCatch m) => [OAuthScope] -> m Credentials
472− => a
446+fromFile ss = do
447+ f <- defaultCredentialsPath
448+ case f of
449+ Just x -> fromFilePath ss x
450+ Nothing -> do
451+ x <- cloudSDKConfigPath
452+ fromFilePath ss x
453+
454+-- | Attempt to load either a @service_account@ or @authorized_user@ formatted
455+-- file to obtain the credentials neccessary to perform a token refresh from
456+-- the specified file.
457+--
458+-- The specified 'Scope's are used to authorize any @service_account@ that is
459+-- found with the appropriate scopes, otherwise they are not used. See the
460+-- top-level module of each individual @gogol-*@ library for a list of available
461+-- scopes, such as @Network.Google.Compute.computeScope@.
462+fromFilePath :: (MonadIO m, MonadCatch m)
463+ => [OAuthScope]
464+ -> FilePath
465+ -> m Credentials
466+fromFilePath ss f = do
467+ p <- liftIO (doesFileExist f)
468+ unless p $
469+ throwM (MissingFileError f)
470+ bs <- liftIO (LBS.readFile f)
471+ either (throwM . InvalidFileError f . Text.pack) pure
472+ (fromJSONCredentials ss bs)
473+
474+fromJSONCredentials :: [OAuthScope]
475+ -> LBS.ByteString
476+ -> Either String Credentials
477+fromJSONCredentials ss bs = do
478+ v <- eitherDecode' bs
479+ let x = (`FromAccount` ss) <$> parseEither parseJSON v
480+ y = FromUser <$> parseEither parseJSON v
481+ case (x, y) of
482+ (Left xe, Left ye) -> Left $
483+ "Failed parsing service_account: " ++ xe ++
484+ ", Failed parsing authorized_user: " ++ ye
485+ _ -> x <|> y
486+
487+authorize :: (MonadIO m, MonadCatch m)
488+ => Client.Request
489+ -> Store
473− -> Logger
490+ -> Logger
491+ -> Manager
492+ -> m Client.Request
493+authorize rq s l m = bearer <$> getToken s l m
494+ where
495+ bearer t = rq
496+ { Client.requestHeaders =
497+ ( hAuthorization
498+ , "Bearer " <> Text.encodeUtf8 (accessToText (_tokenAccess t))
499+ ) : Client.requestHeaders rq
500+ }
501+
502+getToken :: (MonadIO m, MonadCatch m)
503+ => Store
504+ -> Logger
474− -> Manager
505+ -> Manager
475− -> m (Expires a)
506+ -> m OAuthToken
476−
507+getToken s l m = do
477−instance Refresh ServiceAccount where
508+ x <- liftIO (readMVar s)
478− refresh s l m = do
509+ mx <- validateToken x
479− b <- jwtEncode s
510+ case mx of
511+ Just t -> pure t
512+ Nothing -> liftIO . modifyMVar s $ \y -> do
513+ my <- validateToken y
514+ case my of
515+ Just t -> pure (y, t)
516+ Nothing ->
517+ case y of
518+ Exchange c -> do
519+ t <- exchange c l m
520+ pure (Refresh c t, t)
521+ Refresh c t -> do
522+ t' <- refresh c t l m
523+ pure (Refresh c t', t')
524+
525+validateToken :: MonadIO m => Auth -> m (Maybe OAuthToken)
526+validateToken Exchange {} = pure Nothing
527+validateToken (Refresh _ t) = do
528+ ts <- liftIO getCurrentTime
529+ if ts < _tokenExpiry t
530+ then pure (Just t)
531+ else pure Nothing
532+
533+exchange :: (MonadIO m, MonadCatch m)
534+ => Credentials
535+ -> Logger
536+ -> Manager
537+ -> m OAuthToken
538+exchange c l m =
539+ case c of
540+ FromMetadata s -> refreshMetadata s l m
541+ FromAccount a ss -> refreshAssertion a ss l m
542+ FromClient c' n -> exchangeCode c' n l m
543+ FromUser AuthorizedUser{..} ->
544+ refreshToken _userId _userSecret (Just _userRefresh) l m
545+
546+formURL :: OAuthClient -> [OAuthScope] -> Text
547+formURL OAuthClient{..} ss =
548+ LText.toStrict . LText.decodeUtf8 . Build.toLazyByteString $
549+ buildText accountsURL
550+ <> "?response_type=code"
551+ <> "&client_id=" <> buildText _clientId
552+ <> "&redirect_uri=" <> buildText redirectURI
553+ <> "&scope=" <> queryEncodeScopes ss
554+
555+redirectURI :: Text
556+redirectURI = "urn:ietf:wg:oauth:2.0:oob"
557+
558+exchangeCode :: (MonadIO m, MonadCatch m)
559+ => OAuthClient
560+ -> OAuthCode
561+ -> Logger
562+ -> Manager
563+ -> m OAuthToken
564+exchangeCode OAuthClient{..} n = refreshRequest $
565+ accountsRequest
566+ { Client.requestBody = buildBody $
567+ "grant_type=authorization_code"
568+ <> "&client_id=" <> buildText _clientId
569+ <> "&client_secret=" <> buildText _clientSecret
570+ <> "&code=" <> buildText n
571+ <> "&redirect_uri=" <> buildText redirectURI
572+ }
573+
574+refresh :: (MonadIO m, MonadCatch m)
575+ => Credentials
576+ -> OAuthToken
577+ -> Logger
578+ -> Manager
579+ -> m OAuthToken
580+refresh c OAuthToken{..} l m =
581+ case c of
582+ FromMetadata s -> refreshMetadata s l m
583+ FromAccount a ss -> refreshAssertion a ss l m
584+ FromClient OAuthClient{..} _ ->
585+ refreshToken _clientId _clientSecret _tokenRefresh l m
586+ FromUser AuthorizedUser{..} ->
587+ refreshToken _userId _userSecret
588+ (_tokenRefresh <|> Just _userRefresh) l m
589+
590+refreshMetadata :: (MonadIO m, MonadCatch m)
591+ => ServiceId
592+ -> Logger
593+ -> Manager
594+ -> m OAuthToken
595+refreshMetadata s = refreshRequest $
596+ metadataRequest
597+ { Client.path = "instance/service-accounts/"
598+ <> Text.encodeUtf8 (serviceIdToText s)
599+ <> "/token"
600+ }
601+
602+refreshToken :: (MonadIO m, MonadCatch m)
603+ => ClientId
604+ -> Secret
605+ -> Maybe RefreshToken
606+ -> Logger
607+ -> Manager
608+ -> m OAuthToken
609+refreshToken c s r = refreshRequest $
610+ accountsRequest
611+ { Client.requestBody = buildBody $
612+ "grant_type=refresh_token"
613+ <> "&client_id=" <> buildText c
614+ <> "&client_secret=" <> buildText s
615+ <> maybe mempty ("&refresh_token=" <>) (buildText <$> r)
616+ }
617+
618+refreshAssertion :: (MonadIO m, MonadCatch m)
619+ => ServiceAccount
620+ -> [OAuthScope]
621+ -> Logger
622+ -> Manager
623+ -> m OAuthToken
624+refreshAssertion s ss l m = do
625+ b <- encodeJWTBearer s ss
480− let rq = accountsRequest
626+ let rq = accountsRequest
481− { Client.requestBody = RequestBodyBS $
627+ { Client.requestBody = buildBody $
482− "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"
628+ "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"
483− <> "&assertion="
629+ <> "&assertion="
484− <> b
630+ <> Build.byteString b
485− }
631+ }
486− refreshRequest s rq l m
632+ refreshRequest rq l m
487−
633+
488−jwtEncode :: (MonadIO m, MonadThrow m)
634+encodeJWTBearer :: (MonadIO m, MonadThrow m)
489− => ServiceAccount
635+ => ServiceAccount
636+ -> [OAuthScope]
490− -> m ByteString
637+ -> m ByteString
491−jwtEncode s = liftIO $ do
638+encodeJWTBearer s ss = liftIO $ do
492 i <- input . truncate <$> getPOSIXTime
639 i <- input . truncate <$> getPOSIXTime
493− r <- signSafer (Just SHA256) (_serviceKey s) i
640+ r <- signSafer (Just SHA256) (_servicePrivateKey s) i
494− either failure (\x -> pure (i <> "." <> signature (base64 x))) r
641+ either failure (pure . concat' i) r
495 where
642 where
643+ concat' i x = i <> "." <> signature (base64 x)
644+
496 failure e = throwM $
645 failure e = throwM $
497 TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing
646 TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing
498
647
@@ -512,30 +661,30 @@ jwtEncode s = liftIO $ do
512 ]
661 ]
513
662
514 payload = base64Encode
663 payload = base64Encode
515− [ "aud" .= Text.pack "https://accounts.google.com/o/oauth2/token"
664+ [ "aud" .= accountsURL
516− , "scope" .= concatScopes (_serviceScope s)
665+ , "scope" .= concatScopes ss
517 , "iat" .= n
666 , "iat" .= n
518 , "exp" .= (n + maxTokenLifetimeSeconds)
667 , "exp" .= (n + maxTokenLifetimeSeconds)
519 , "iss" .= _serviceEmail s
668 , "iss" .= _serviceEmail s
520 ]
669 ]
521
670
522−instance Refresh AuthorisedUser where
671+queryEncodeScopes :: [OAuthScope] -> Build.Builder
523− refresh u@AuthorisedUser{..} = refreshRequest u $
672+queryEncodeScopes =
524− accountsRequest
673+ mconcat
525− { Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
674+ . intersperse "+"
526− "grant_type=refresh_token"
675+ . map (urlEncodeBuilder True . Text.encodeUtf8)
527− <> "&client_id=" <> clientIdToText _userId
676+ . coerce
528− <> "&client_secret=" <> _userSecret
677+
529− <> "&refresh_token=" <> _userRefresh
678+concatScopes :: [OAuthScope] -> LText.Text
530− }
679+concatScopes =
531−
680+ TBuild.toLazyText
532−instance Refresh ServiceId where
681+ . mconcat
533− refresh sid = refreshRequest sid $
682+ . intersperse " "
534− metadataRequest
683+ . map TBuild.fromText
535− { Client.path = "instance/service-accounts/"
684+ . coerce
536− <> Text.encodeUtf8 (serviceIdToText sid)
685+
537− <> "/token"
686+accountsURL :: Text
538− }
687+accountsURL = "https://accounts.google.com/o/oauth2/token"
539
688
540accountsRequest :: Client.Request
689accountsRequest :: Client.Request
541accountsRequest = def
690accountsRequest = def
@@ -545,16 +694,17 @@ accountsRequest = def
545 , Client.checkStatus = \_ _ _ -> Nothing
694 , Client.checkStatus = \_ _ _ -> Nothing
546 , Client.method = "POST"
695 , Client.method = "POST"
547 , Client.path = "/o/oauth2/token"
696 , Client.path = "/o/oauth2/token"
697+ , Client.requestHeaders =
548− , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]
698+ [ (hContentType, "application/x-www-form-urlencoded")
699+ ]
549 }
700 }
550
701
551refreshRequest :: (MonadIO m, MonadCatch m)
702refreshRequest :: (MonadIO m, MonadCatch m)
552− => a
553− -> Client.Request
703+ => Client.Request
554 -> Logger
704 -> Logger
555 -> Manager
705 -> Manager
556− -> m (Expires a)
706+ -> m OAuthToken
557−refreshRequest r rq l m = do
707+refreshRequest rq l m = do
558 logDebug l rq -- debug:ClientRequest
708 logDebug l rq -- debug:ClientRequest
559
709
560 rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)
710 rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)
@@ -572,8 +722,7 @@ refreshRequest r rq l m = do
572 success s bs = do
722 success s bs = do
573 f <- parseErr s bs
723 f <- parseErr s bs
574 ts <- liftIO getCurrentTime
724 ts <- liftIO getCurrentTime
575− let Bearer {..} = f ts
725+ pure (f ts)
576− pure $! Expires _bearerExpiry _bearerAccess r
577
726
578 failure s bs = do
727 failure s bs = do
579 let e = "Failure refreshing token from " <> host <> path
728 let e = "Failure refreshing token from " <> host <> path
@@ -586,7 +735,8 @@ refreshRequest r rq l m = do
586 case parseLBS bs of
735 case parseLBS bs of
587 Right !x -> pure x
736 Right !x -> pure x
588 Left e -> do
737 Left e -> do
738+ logError l $
589− logError l $ "[Parse Error] Failure parsing token refresh " <> build e
739+ "[Parse Error] Failure parsing token refresh " <> build e
590 refreshErr s e Nothing
740 refreshErr s e Nothing
591
741
592 refreshErr :: MonadThrow m => Status -> Text -> Maybe Text -> m a
742 refreshErr :: MonadThrow m => Status -> Text -> Maybe Text -> m a
@@ -603,3 +753,9 @@ base64Encode = base64 . LBS.toStrict . encode . object
603
753
604base64 :: ByteArray a => a -> ByteString
754base64 :: ByteArray a => a -> ByteString
605base64 = convertToBase Base64URLUnpadded
755base64 = convertToBase Base64URLUnpadded
756+
757+buildBody :: Builder -> RequestBody
758+buildBody = RequestBodyLBS . Build.toLazyByteString
759+
760+buildText :: ToText a => a -> Builder
761+buildText = build . toText
gogol/src/Network/Google/Env.hs+31−17
@@ -25,7 +25,7 @@ data Env = Env
25 { _envLogger :: !Logger
25 { _envLogger :: !Logger
26 , _envOverride :: !(Dual (Endo Service))
26 , _envOverride :: !(Dual (Endo Service))
27 , _envManager :: !Manager
27 , _envManager :: !Manager
28− , _envAuth :: !Auth
28+ , _envStore :: !Store
29 }
29 }
30
30
31-- Note: The strictness annotations aobe are applied to ensure
31-- Note: The strictness annotations aobe are applied to ensure
@@ -44,13 +44,13 @@ class HasEnv a where
44 -- | The 'Manager' used to create and manage open HTTP connections.
44 -- | The 'Manager' used to create and manage open HTTP connections.
45 envManager :: Lens' a Manager
45 envManager :: Lens' a Manager
46
46
47− -- | The credentials used to sign requests for authentication with Google.
47+ -- | The credential store used to sign requests for authentication with Google.
48− envAuth :: Lens' a Auth
48+ envStore :: Lens' a Store
49
49
50− envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a })
50+ envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a })
51 envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })
51 envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })
52 envManager = environment . lens _envManager (\s a -> s { _envManager = a })
52 envManager = environment . lens _envManager (\s a -> s { _envManager = a })
53− envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })
53+ envStore = environment . lens _envStore (\s a -> s { _envStore = a })
54
54
55instance HasEnv Env where
55instance HasEnv Env where
56 environment = id
56 environment = id
@@ -101,21 +101,35 @@ reconfigure = local . configure
101timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a
101timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a
102timeout s = local (override (serviceTimeout ?~ s))
102timeout s = local (override (serviceTimeout ?~ s))
103
103
104−-- | Creates a new environment with a new 'Manager' without debug logging
104+-- | Creates a new environment with a new 'Manager', without logging.
105−-- and uses 'getAuth' to expand/discover the supplied 'Credentials'.
105+-- Credentials are determined by calling 'discover'. Use 'newEnvWith' to supply
106+-- custom credentials such as an 'OAuthClient' and 'OAuthCode'.
107+--
106-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
108-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
107--
109--
108−-- /See:/ 'newEnvWith', 'defaultScopes'.
110+-- /See:/ 'newEnvWith', 'discover'.
109−newEnv :: (MonadIO m, MonadCatch m) => Credentials -> [OAuthScope] -> m Env
111+newEnv :: (MonadIO m, MonadCatch m) => [OAuthScope] -> m Env
112+newEnv ss = do
110−newEnv c ss = liftIO (newManager tlsManagerSettings) >>= newEnvWith c ss logger
113+ m <- liftIO (newManager tlsManagerSettings)
111− where
114+ c <- discover ss m
112− logger _ _ = pure ()
115+ newEnvWith c m
113−
116+
117+-- | Creates a new environment without logging, using the supplied 'Manager' and
118+-- credentials. Use either the 'Credentials' constructor or
119+-- see one of following functions from "Network.Google.Auth" for how to instantiate
120+-- a 'Credentials' value:
121+--
122+-- * 'discover' - Attempt to discover credentials from the underlying host.
123+--
124+-- * 'fromFile' - Attempt to load credentials from the well known file locations.
125+--
126+-- * 'fromFilePath' - Supply a file path to load credentials from.
127+--
128+-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
129+--
114−-- | /See:/ 'newEnv'
130+-- /See:/ 'newEnv'.
115newEnvWith :: (MonadIO m, MonadCatch m)
131newEnvWith :: (MonadIO m, MonadCatch m)
116 => Credentials
132 => Credentials
117− -> [OAuthScope]
118− -> Logger
119 -> Manager
133 -> Manager
120 -> m Env
134 -> m Env
121−newEnvWith c ss l m = Env l mempty m <$> getAuth c ss l m
135+newEnvWith c m = Env (\_ _ -> pure ()) mempty m <$> emptyStore c
gogol/src/Network/Google/Internal/HTTP.hs+1−1
@@ -57,7 +57,7 @@ perform Env{..} x = catches go handlers
57
57
58 go = liftResourceT $ do
58 go = liftResourceT $ do
59 (ct, b) <- getContent _rqBody
59 (ct, b) <- getContent _rqBody
60− rq <- authorise _envLogger _envManager (request ct b) _envAuth
60+ rq <- authorize (request ct b) _envStore _envLogger _envManager
61
61
62 logDebug _envLogger rq -- debug:ClientRequest
62 logDebug _envLogger rq -- debug:ClientRequest
63
63