git.iko.soy/gogol
on develop help sign in
Merge branch 'feature/split-auth-modules' into develop
c69f45aBrendan Hay
core/src/Network/Google/Types.hs+6−6
compare with develop
unifiedsplit
@@ -61,22 +61,22 @@ data AltMedia = AltMedia deriving (Eq, Ord, Show, Read, Generic, Typeable)
61instance ToText AltJSON where toText = const "json"
61instance ToText AltJSON where toText = const "json"
62instance ToText AltMedia where toText = const "media"
62instance ToText AltMedia where toText = const "media"
63
63
64−newtype OAuthScope = OAuthScope { scopeToText :: Text }
64+newtype OAuthScope = OAuthScope Text
65 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
65 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
66
66
67−newtype AccessToken = AccessToken { accessToText :: Text }
67+newtype AccessToken = AccessToken Text
68 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
68 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
69
69
70−newtype RefreshToken = RefreshToken { refreshToText :: Text }
70+newtype RefreshToken = RefreshToken Text
71 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
71 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromText, ToText, FromJSON, ToJSON)
72
72
73−newtype ClientId = ClientId { clientIdToText :: Text }
73+newtype ClientId = ClientId Text
74 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
74 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
75
75
76−newtype Secret = Secret { secretToText :: Text }
76+newtype Secret = Secret Text
77 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
77 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
78
78
79−newtype ServiceId = ServiceId { serviceIdToText :: Text }
79+newtype ServiceId = ServiceId Text
80 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
80 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
81
81
82newtype MediaDownload a = MediaDownload a
82newtype MediaDownload a = MediaDownload a
gogol/gogol.cabal+6−1
@@ -41,11 +41,16 @@ library
41 exposed-modules:
41 exposed-modules:
42 Network.Google
42 Network.Google
43 , Network.Google.Auth
43 , Network.Google.Auth
44+ , Network.Google.Auth.ApplicationDefaultCredentials
45+ , Network.Google.Auth.Device
46+ , Network.Google.Auth.InstalledApplication
47+ , Network.Google.Auth.ServiceAccount
44 , Network.Google.Compute.Metadata
48 , Network.Google.Compute.Metadata
45 , Network.Google.Env
49 , Network.Google.Env
46
50
47 other-modules:
51 other-modules:
48− Network.Google.Internal.Body
52+ Network.Google.Internal.Auth
53+ , Network.Google.Internal.Body
49 , Network.Google.Internal.HTTP
54 , Network.Google.Internal.HTTP
50 , Network.Google.Internal.Logger
55 , Network.Google.Internal.Logger
51 , Network.Google.Internal.Multipart
56 , Network.Google.Internal.Multipart
gogol/src/Network/Google/Auth.hs+105−542
@@ -1,9 +1,7 @@
1−{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
@@ -30,39 +28,28 @@ module Network.Google.Auth
30 , fromFilePath
28 , fromFilePath
31 , fromJSONCredentials
29 , fromJSONCredentials
32
30
33− -- ** Thread-safe Storage
34− , Auth (..)
35− , Store
36− , emptyStore
37−
38 -- ** Authorizing Requests
31 -- ** Authorizing Requests
39 , authorize
32 , authorize
40
33
41 -- ** Constructing Callback URLs
34 -- ** Constructing Callback URLs
42 , formURL
35 , formURL
43− , redirectURI
36+
44− , accountsURL
37+ -- ** Thread-safe Storage
38+ , Auth (..)
39+ , Store
40+ , initStore
41+ , exchange
42+ , refresh
45
43
46 -- ** Default Constants
44 -- ** Default Constants
47− -- *** Google Compute Engine
48 , checkGCEVar
45 , checkGCEVar
49−
50− -- *** Cloud SDK
51 , cloudSDKConfigDir
46 , cloudSDKConfigDir
52− , cloudSDKConfigPath
53−
54− -- *** Application Default Credentials
55 , defaultCredentialsFile
47 , defaultCredentialsFile
56− , defaultCredentialsPath
57
48
58 -- ** Handling Errors
49 -- ** Handling Errors
59 , AsAuthError (..)
50 , AsAuthError (..)
60 , AuthError (..)
51 , AuthError (..)
61
52
62− -- * Credential Types
63− , ServiceAccount (..)
64− , AuthorizedUser (..)
65−
66 -- * OAuth Types
53 -- * OAuth Types
67 , OAuthClient (..)
54 , OAuthClient (..)
68 , OAuthToken (..)
55 , OAuthToken (..)
@@ -75,278 +62,56 @@ module Network.Google.Auth
75 , Secret (..)
62 , Secret (..)
76 , ServiceId (..)
63 , ServiceId (..)
77 , ClientId (..)
64 , ClientId (..)
78−
79− -- * Exchange and Refresh Internals
80− , getToken
81− , validateToken
82−
83− , exchange
84− , exchangeCode
85−
86− , refresh
87− , refreshMetadata
88− , refreshToken
89− , refreshAssertion
90 ) where
65 ) where
91
66
92import Control.Applicative
67import Control.Applicative
93import Control.Concurrent
68import Control.Concurrent
94import Control.Exception.Lens
69import Control.Exception.Lens
95−import Control.Lens hiding (coerce, (.=))
70+import Control.Lens hiding
71+ (coerce,
72+ (.=))
96import Control.Monad
73import Control.Monad
97import Control.Monad.Catch
74import Control.Monad.Catch
98import Control.Monad.IO.Class
75import Control.Monad.IO.Class
99−import Crypto.Hash.Algorithms (SHA256 (..))
76+import Crypto.Hash.Algorithms (SHA256 (..))
100−import Crypto.PubKey.RSA.PKCS15 (signSafer)
77+import Crypto.PubKey.RSA.PKCS15 (signSafer)
101−import Crypto.PubKey.RSA.Types (PrivateKey)
78+import Crypto.PubKey.RSA.Types (PrivateKey)
102import Data.Aeson
79import Data.Aeson
103import Data.Aeson.Types
80import Data.Aeson.Types
104import Data.ByteArray
81import Data.ByteArray
105import Data.ByteArray.Encoding
82import Data.ByteArray.Encoding
106−import Data.ByteString (ByteString)
83+import Data.ByteString (ByteString)
107−import Data.ByteString.Builder (Builder)
84+import Data.ByteString.Builder (Builder)
108−import qualified Data.ByteString.Builder as Build
85+import qualified Data.ByteString.Builder as Build
109−import qualified Data.ByteString.Char8 as BS8
86+import qualified Data.ByteString.Char8 as BS8
110−import qualified Data.ByteString.Lazy as LBS
87+import qualified Data.ByteString.Lazy as LBS
111import Data.Coerce
88import Data.Coerce
112−import Data.Default.Class (def)
89+import Data.Default.Class (def)
113−import Data.List (intersperse)
90+import Data.List (intersperse)
114import Data.String
91import Data.String
115−import qualified Data.Text as Text
92+import qualified Data.Text as Text
116−import qualified Data.Text.Encoding as Text
93+import qualified Data.Text.Encoding as Text
117−import qualified Data.Text.Lazy as LText
118−import qualified Data.Text.Lazy.Builder as TBuild
119−import qualified Data.Text.Lazy.Encoding as LText
120import Data.Time
94import Data.Time
121import Data.Time.Clock.POSIX
95import Data.Time.Clock.POSIX
122import Data.Typeable
96import Data.Typeable
123import Data.X509
97import Data.X509
124import Data.X509.Memory
98import Data.X509.Memory
99+import Network.Google.Auth.ApplicationDefaultCredentials
100+import Network.Google.Auth.Device
101+import Network.Google.Auth.InstalledApplication
102+import Network.Google.Auth.ServiceAccount
125import Network.Google.Compute.Metadata
103import Network.Google.Compute.Metadata
104+import Network.Google.Internal.Auth
126import Network.Google.Internal.Logger
105import Network.Google.Internal.Logger
127−import Network.Google.Prelude hiding (buildText)
106+import Network.Google.Prelude
128−import Network.HTTP.Conduit hiding (Request)
107+import Network.HTTP.Conduit hiding
108+ (Request)
129−import qualified Network.HTTP.Conduit as Client
109+import qualified Network.HTTP.Conduit as Client
130import Network.HTTP.Types
110import Network.HTTP.Types
131−import System.Directory (doesFileExist,
111+import System.Directory (doesFileExist, getHomeDirectory)
132− getHomeDirectory)
133−import System.Environment (lookupEnv)
112+import System.Environment (lookupEnv)
134−import System.FilePath ((</>))
113+import System.FilePath ((</>))
135−import System.Info (os)
114+import System.Info (os)
136−
137−-- | 1 hour in seconds.
138−maxTokenLifetimeSeconds :: Int
139−maxTokenLifetimeSeconds = 3600
140−
141−-- | The environment variable name which is used to specify the directory
142−-- containing the @application_default_credentials.json@ generated by @gcloud init@.
143−cloudSDKConfigDir :: String
144−cloudSDKConfigDir = "CLOUDSDK_CONFIG"
145−
146−-- | The environment variable pointing the file with local
147−-- Application Default Credentials.
148−defaultCredentialsFile :: String
149−defaultCredentialsFile = "GOOGLE_APPLICATION_CREDENTIALS"
150−
151−-- | An error thrown when attempting to read AuthN/AuthZ information.
152−data AuthError
153− = RetrievalError HttpException
154− | MissingFileError FilePath
155− | InvalidFileError FilePath Text
156− | TokenRefreshError Status Text (Maybe Text)
157− deriving (Show, Typeable)
158−
159−instance Exception AuthError
160−
161−class AsAuthError a where
162− -- | A general authentication error.
163− _AuthError :: Prism' a AuthError
164− {-# MINIMAL _AuthError #-}
165−
166− -- | An error occured while communicating over HTTP with either then
167− -- local metadata or remote accounts.google.com endpoints.
168− _RetrievalError :: Prism' a HttpException
169−
170− -- | The specified default credentials file could not be found.
171− _MissingFileError :: Prism' a FilePath
172−
173− -- | An error occured parsing the default credentials file.
174− _InvalidFileError :: Prism' a (FilePath, Text)
175−
176− -- | An error occured when attempting to refresh a token.
177− _TokenRefreshError :: Prism' a (Status, Text, Maybe Text)
178−
179− _RetrievalError = _AuthError . _RetrievalError
180− _MissingFileError = _AuthError . _MissingFileError
181− _InvalidFileError = _AuthError . _InvalidFileError
182− _TokenRefreshError = _AuthError . _TokenRefreshError
183−
184−instance AsAuthError SomeException where
185− _AuthError = exception
186−
187−instance AsAuthError AuthError where
188− _AuthError = id
189−
190− _RetrievalError = prism RetrievalError $ \case
191− RetrievalError e -> Right e
192− x -> Left x
193−
194− _MissingFileError = prism MissingFileError $ \case
195− MissingFileError f -> Right f
196− x -> Left x
197−
198− _InvalidFileError = prism
199− (uncurry InvalidFileError)
200− (\case
201− InvalidFileError f e -> Right (f, e)
202− x -> Left x)
203−
204− _TokenRefreshError = prism
205− (\(s, e, d) -> TokenRefreshError s e d)
206− (\case
207− TokenRefreshError s e d -> Right (s, e, d)
208− x -> Left x)
209−
210−-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
211−-- default application credentials filepath.
212−defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
213−defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile)
214−
215−-- | Return the filepath to the Cloud SDK well known file location such as
216−-- @~\/.config\/gcloud\/application_default_credentials.json@.
217−cloudSDKConfigPath :: MonadIO m => m FilePath
218−cloudSDKConfigPath = do
219− m <- liftIO (lookupEnv cloudSDKConfigDir)
220− case m of
221− Just d -> pure $! d </> "application_default_credentials.json"
222− Nothing -> do
223− d <- getConfigDirectory
224− pure $! d </> "gcloud/application_default_credentials.json"
225−
226−getConfigDirectory :: MonadIO m => m FilePath
227−getConfigDirectory = do
228− h <- liftIO getHomeDirectory
229− if os == "windows"
230− then pure h
231− else pure $! h </> ".config"
232−
233−-- | Given a client identifier, client secret, and a list of scopes to authorize,
234−-- construct a URL that can be used to obtain the 'OAuthCode' required to
235−-- instantiate 'FromClient'-style credentials.
236−formURL :: OAuthClient -> [OAuthScope] -> Text
237−formURL OAuthClient{..} ss =
238− LText.toStrict . LText.decodeUtf8 . Build.toLazyByteString $
239− buildText accountsURL
240− <> "?response_type=code"
241− <> "&client_id=" <> buildText _clientId
242− <> "&redirect_uri=" <> buildText redirectURI
243− <> "&scope=" <> queryEncodeScopes ss
244−
245−-- | @urn:ietf:wg:oauth:2.0:oob@.
246−redirectURI :: Text
247−redirectURI = "urn:ietf:wg:oauth:2.0:oob"
248−
249−{-| Service Account credentials which are typically generated/download
250−from the Google Developer console of the following form:
251−
252−@
253−{
254− \"type\": \"service_account\",
255− \"private_key_id\": \"303ad77e5efdf2ce952DFa\",
256− \"private_key\": \"-----BEGIN PRIVATE KEY-----\n...\n\",
257− \"client_email\": \"email@serviceaccount.com\",
258− \"client_id\": \"035-2-310.useraccount.com\"
259−}
260−@
261−
262−The private key is used to sign a JSON Web Token (JWT) of the
263−grant_type @urn:ietf:params:oauth:grant-type:jwt-bearer@, which is sent to
264−'accountsURL' to obtain a valid 'OAuthToken'. This process requires explicitly
265−specifying which 'Scope's the resulting 'OAuthToken' is authorized to access.
266−-}
267−data ServiceAccount = ServiceAccount
268− { _serviceId :: !ClientId
269− , _serviceEmail :: !Text
270− , _serviceKeyId :: !Text
271− , _servicePrivateKey :: !PrivateKey
272− } deriving (Eq, Show)
273−
274−instance FromJSON ServiceAccount where
275− parseJSON = withObject "service_account" $ \o -> do
276− bs <- Text.encodeUtf8 <$> o .: "private_key"
277− k <- case listToMaybe (readKeyFileFromMemory bs) of
278− Just (PrivKeyRSA k) -> pure k
279− _ ->
280− fail "Unable to parse key contents from \"private_key\""
281− ServiceAccount
282− <$> o .: "client_id"
283− <*> o .: "client_email"
284− <*> o .: "private_key_id"
285− <*> pure k
286−
287−{-| Authorized User credentials which are typically generated by the Cloud SDK
288−Tools such as @gcloud init@, of the following form:
289−
290−@
291−{
292− \"type\": \"authorized_user\",
293− \"client_id\": \"32555940559.apps.googleusercontent.com\",
294− \"client_secret\": \"Zms2qjJy2998hD4CTg2ejr2\",
295− \"refresh_token\": \"1/B3gM1x35v.VtqffS1n5w-rSJ\"
296−}
297−@
298−
299−The secret and refresh token are used to obtain a valid 'OAuthToken' from
300−'accountsURL' using grant_type @refresh_token@.
301−-}
302−data AuthorizedUser = AuthorizedUser
303− { _userId :: !ClientId
304− , _userRefresh :: !RefreshToken
305− , _userSecret :: !Secret
306− } deriving (Eq, Show)
307−
308−instance FromJSON AuthorizedUser where
309− parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser
310− <$> o .: "client_id"
311− <*> o .: "refresh_token"
312− <*> o .: "client_secret"
313−
314−-- | A client identifier and accompanying secret used to obtain/refresh a token.
315−data OAuthClient = OAuthClient
316− { _clientId :: !ClientId
317− , _clientSecret :: !Secret
318− } deriving (Eq, Show)
319−
320−{-| An OAuth bearer type token of the following form:
321−
322−@
323−{
324− \"token_type\": \"Bearer\",
325− \"access_token\": \"eyJhbGci...\",
326− \"refresh_token\": \"1/B3gq9K...\",
327− \"expires_in\": 3600,
328− ...
329−}
330−@
331−
332−The '_tokenAccess' field will be inserted verbatim into the
333−@Authorization: Bearer ...@ header for all HTTP requests.
334−-}
335−data OAuthToken = OAuthToken
336− { _tokenAccess :: !AccessToken
337− , _tokenRefresh :: !(Maybe RefreshToken)
338− , _tokenExpiry :: !UTCTime
339− } deriving (Eq, Show)
340−
341−instance FromJSON (UTCTime -> OAuthToken) where
342− parseJSON = withObject "bearer" $ \o -> do
343− t <- o .: "access_token"
344− r <- o .:? "refresh_token"
345− e <- o .: "expires_in" <&> fromInteger
346− pure (OAuthToken t r . addUTCTime e)
347−
348−newtype OAuthCode = OAuthCode { codeToText :: Text }
349− deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
350
115
351-- | The supported credential mechanisms.
116-- | The supported credential mechanisms.
352data Credentials
117data Credentials
@@ -375,24 +140,6 @@ data Credentials
375 -- An 'AuthorizedUser' is typically created by the @gcloud init@ command
140 -- An 'AuthorizedUser' is typically created by the @gcloud init@ command
376 -- of the Google CloudSDK Tools.
141 -- of the Google CloudSDK Tools.
377
142
378−-- | A credentials value in one of two possible states, pre-exchange and
379−-- containing a valid, but possibly expired access token.
380−data Auth
381− = Exchange !Credentials
382− -- ^ Signifies that the initial token refresh has not occured, and the
383− -- 'Credentials' need to be signed and exchanged for a valid 'OAuthToken'.
384−
385− | Refresh !Credentials !OAuthToken
386− -- ^ An 'OAuthToken' that can potentially be expired, with the original
387− -- credentials that can be used to perform a refresh.
388−
389−type Store = MVar Auth
390−
391−-- | Construct storage containing the credentials which have not yet been
392−-- exchanged or refreshed.
393−emptyStore :: MonadIO m => Credentials -> m Store
394−emptyStore !c = liftIO . newMVar $ Exchange c
395−
396-- | Attempt credentials discovery via the following steps:
143-- | Attempt credentials discovery via the following steps:
397--
144--
398-- * Read the default credentials from a file specified by
145-- * Read the default credentials from a file specified by
@@ -459,6 +206,8 @@ fromFilePath ss f = do
459 either (throwM . InvalidFileError f . Text.pack) pure
206 either (throwM . InvalidFileError f . Text.pack) pure
460 (fromJSONCredentials ss bs)
207 (fromJSONCredentials ss bs)
461
208
209+-- | Attempt to parse either a @service_account@ or @authorized_user@ formatted
210+-- JSON value to obtain credentials.
462fromJSONCredentials :: [OAuthScope]
211fromJSONCredentials :: [OAuthScope]
463 -> LBS.ByteString
212 -> LBS.ByteString
464 -> Either String Credentials
213 -> Either String Credentials
@@ -472,21 +221,31 @@ fromJSONCredentials ss bs = do
472 ", Failed parsing authorized_user: " ++ ye
221 ", Failed parsing authorized_user: " ++ ye
473 _ -> x <|> y
222 _ -> x <|> y
474
223
475−authorize :: (MonadIO m, MonadCatch m)
224+-- | An 'OAuthToken' that can potentially be expired, with the original
476− => Client.Request
225+-- credentials that can be used to perform a refresh.
226+data Auth = Auth
227+ { _credentials :: !Credentials
228+ , _token :: !OAuthToken
229+ }
230+
231+-- | Check if the given token is still valid, ie. younger than the projected
232+-- expiry time.
233+validate :: MonadIO m => Auth -> m Bool
234+validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime
235+
477− -> Store
236+type Store = MVar Auth
237+
238+-- | Construct storage containing the credentials which have not yet been
239+-- exchanged or refreshed.
240+initStore :: (MonadIO m, MonadCatch m)
241+ => Credentials
478 -> Logger
242 -> Logger
479 -> Manager
243 -> Manager
480− -> m Client.Request
244+ -> m Store
481−authorize rq s l m = bearer <$> getToken s l m
245+initStore c l m = exchange c l m >>= liftIO . newMVar
482− where
483− bearer t = rq
484− { Client.requestHeaders =
485− ( hAuthorization
486− , "Bearer " <> Text.encodeUtf8 (accessToText (_tokenAccess t))
487− ) : Client.requestHeaders rq
488− }
489
246
247+-- | Concurrently read the current token, and if expired, then
248+-- safely perform a single serial refresh.
490getToken :: (MonadIO m, MonadCatch m)
249getToken :: (MonadIO m, MonadCatch m)
491 => Store
250 => Store
492 -> Logger
251 -> Logger
@@ -494,255 +253,59 @@ getToken :: (MonadIO m, MonadCatch m)
494 -> m OAuthToken
253 -> m OAuthToken
495getToken s l m = do
254getToken s l m = do
496 x <- liftIO (readMVar s)
255 x <- liftIO (readMVar s)
497− mx <- validateToken x
256+ mx <- validate x
498− case mx of
257+ if mx
499− Just t -> pure t
258+ then pure (_token x)
500− Nothing -> liftIO . modifyMVar s $ \y -> do
259+ else liftIO . modifyMVar s $ \y -> do
501− my <- validateToken y
260+ my <- validate y
502− case my of
261+ if my
503− Just t -> pure (y, t)
262+ then pure (y, _token y)
504− Nothing ->
263+ else do
505− case y of
264+ z <- refresh y l m
506− Exchange c -> do
265+ pure (z, _token z)
507− t <- exchange c l m
266+
508− pure (Refresh c t, t)
267+-- | Perform the initial credentials exchange to obtain a valid 'OAuthToken'
509− Refresh c t -> do
268+-- suitable for authorizing requests.
510− t' <- refresh c t l m
511− pure (Refresh c t', t')
512−
513−validateToken :: MonadIO m => Auth -> m (Maybe OAuthToken)
514−validateToken Exchange {} = pure Nothing
515−validateToken (Refresh _ t) = do
516− ts <- liftIO getCurrentTime
517− if ts < _tokenExpiry t
518− then pure (Just t)
519− else pure Nothing
520−
521exchange :: (MonadIO m, MonadCatch m)
269exchange :: (MonadIO m, MonadCatch m)
522 => Credentials
270 => Credentials
523 -> Logger
271 -> Logger
524 -> Manager
272 -> Manager
525− -> m OAuthToken
273+ -> m Auth
526−exchange c l m =
274+exchange c l = fmap (Auth c) . action l
275+ where
527− case c of
276+ action = case c of
528− FromMetadata s -> refreshMetadata s l m
277+ FromMetadata s -> metadataToken s
529− FromAccount a ss -> refreshAssertion a ss l m
278+ FromAccount a ss -> serviceAccountToken a ss
530− FromClient c' n -> exchangeCode c' n l m
279+ FromClient c n -> exchangeCode c n
531− FromUser AuthorizedUser{..} ->
280+ FromUser u -> authorizedUserToken u Nothing
532− refreshToken _userId _userSecret (Just _userRefresh) l m
533−
534−exchangeCode :: (MonadIO m, MonadCatch m)
535− => OAuthClient
536− -> OAuthCode
537− -> Logger
538− -> Manager
539− -> m OAuthToken
540−exchangeCode OAuthClient{..} n = refreshRequest $
541− accountsRequest
542− { Client.requestBody = buildBody $
543− "grant_type=authorization_code"
544− <> "&client_id=" <> buildText _clientId
545− <> "&client_secret=" <> buildText _clientSecret
546− <> "&code=" <> buildText n
547− <> "&redirect_uri=" <> buildText redirectURI
548− }
549
281
282+-- | Refresh an existing 'OAuthToken' using
550refresh :: (MonadIO m, MonadCatch m)
283refresh :: (MonadIO m, MonadCatch m)
551− => Credentials
284+ => Auth
552− -> OAuthToken
553 -> Logger
285 -> Logger
554 -> Manager
286 -> Manager
555− -> m OAuthToken
287+ -> m Auth
556−refresh c OAuthToken{..} l m =
288+refresh (Auth c t) l = fmap (Auth c) . action l
557− case c of
558− FromMetadata s -> refreshMetadata s l m
559− FromAccount a ss -> refreshAssertion a ss l m
560− FromClient OAuthClient{..} _ ->
561− refreshToken _clientId _clientSecret _tokenRefresh l m
562− FromUser AuthorizedUser{..} ->
563− refreshToken _userId _userSecret
564− (_tokenRefresh <|> Just _userRefresh) l m
565−
566−refreshMetadata :: (MonadIO m, MonadCatch m)
567− => ServiceId
568− -> Logger
569− -> Manager
570− -> m OAuthToken
571−refreshMetadata s = refreshRequest $
572− metadataRequest
573− { Client.path = "instance/service-accounts/"
574− <> Text.encodeUtf8 (serviceIdToText s)
575− <> "/token"
576− }
577−
578−refreshToken :: (MonadIO m, MonadCatch m)
579− => ClientId
580− -> Secret
581− -> Maybe RefreshToken
582− -> Logger
583− -> Manager
584− -> m OAuthToken
585−refreshToken c s r = refreshRequest $
586− accountsRequest
587− { Client.requestBody = buildBody $
588− "grant_type=refresh_token"
589− <> "&client_id=" <> buildText c
590− <> "&client_secret=" <> buildText s
591− <> maybe mempty ("&refresh_token=" <>) (buildText <$> r)
592− }
593−
594−refreshAssertion :: (MonadIO m, MonadCatch m)
595− => ServiceAccount
596− -> [OAuthScope]
597− -> Logger
598− -> Manager
599− -> m OAuthToken
600−refreshAssertion s ss l m = do
601− b <- encodeJWTBearer s ss
602− let rq = accountsRequest
603− { Client.requestBody = buildBody $
604− "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"
605− <> "&assertion="
606− <> Build.byteString b
607− }
608− refreshRequest rq l m
609−
610−encodeJWTBearer :: (MonadIO m, MonadThrow m)
611− => ServiceAccount
612− -> [OAuthScope]
613− -> m ByteString
614−encodeJWTBearer s ss = liftIO $ do
615− i <- input . truncate <$> getPOSIXTime
616− r <- signSafer (Just SHA256) (_servicePrivateKey s) i
617− either failure (pure . concat' i) r
618 where
289 where
619− concat' i x = i <> "." <> signature (base64 x)
620−
621− failure e = throwM $
622− TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing
623−
624− signature bs =
625− case BS8.unsnoc bs of
290+ action = case c of
626− Nothing -> mempty
291+ FromMetadata s -> metadataToken s
627− Just (bs', x)
292+ FromAccount a ss -> serviceAccountToken a ss
628− | x == '=' -> bs'
293+ FromClient x _ -> refreshToken x t
629− | otherwise -> bs
294+ FromUser u -> authorizedUserToken u (_tokenRefresh t)
630−
295+
631− input n = header <> "." <> payload
296+-- | Apply the (by way of possible token refresh) a bearer token to the
632− where
297+-- authentication header of a request.
633− header = base64Encode
634− [ "alg" .= ("RS256" :: Text)
635− , "typ" .= ("JWT" :: Text)
636− , "kid" .= _serviceKeyId s
637− ]
638−
639− payload = base64Encode
640− [ "aud" .= accountsURL
641− , "scope" .= concatScopes ss
642− , "iat" .= n
643− , "exp" .= (n + maxTokenLifetimeSeconds)
644− , "iss" .= _serviceEmail s
645− ]
646−
647−-- | @https://accounts.google.com/o/oauth2/token@.
648−accountsURL :: Text
649−accountsURL = "https://accounts.google.com/o/oauth2/token"
650−
651−accountsRequest :: Client.Request
652−accountsRequest = def
653− { Client.host = "accounts.google.com"
654− , Client.port = 443
655− , Client.secure = True
656− , Client.checkStatus = \_ _ _ -> Nothing
657− , Client.method = "POST"
658− , Client.path = "/o/oauth2/token"
659− , Client.requestHeaders =
660− [ (hContentType, "application/x-www-form-urlencoded")
661− ]
662− }
663−
664−refreshRequest :: (MonadIO m, MonadCatch m)
298+authorize :: (MonadIO m, MonadCatch m)
665− => Client.Request
299+ => Client.Request
300+ -> Store
666− -> Logger
301+ -> Logger
667− -> Manager
302+ -> Manager
668− -> m OAuthToken
303+ -> m Client.Request
669−refreshRequest rq l m = do
304+authorize rq s l m = bearer <$> getToken s l m
670− logDebug l rq -- debug:ClientRequest
671−
672− rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)
673−
674− let bs = responseBody rs
675− s = responseStatus rs
676−
677− logDebug l rs -- debug:ClientResponse
678− logTrace l $ "[Response Body]\n" <> bs -- trace:ResponseBody
679−
680− if fromEnum s == 200
681− then success s bs
682− else failure s bs
683 where
305 where
684− success s bs = do
306+ bearer t = rq
685− f <- parseErr s bs
307+ { Client.requestHeaders =
686− ts <- liftIO getCurrentTime
308+ ( hAuthorization
687− pure (f ts)
309+ , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
688−
310+ ) : Client.requestHeaders rq
689− failure s bs = do
311+ }
690− let e = "Failure refreshing token from " <> host <> path
691− logError l $ "[Refresh Error] " <> build e
692− case parseLBS bs of
693− Right x -> refreshErr s (_error x) (_description x)
694− Left _ -> refreshErr s e Nothing
695−
696− parseErr s bs =
697− case parseLBS bs of
698− Right !x -> pure x
699− Left e -> do
700− logError l $
701− "[Parse Error] Failure parsing token refresh " <> build e
702− refreshErr s e Nothing
703−
704− refreshErr :: MonadThrow m => Status -> Text -> Maybe Text -> m a
705− refreshErr s e = throwM . TokenRefreshError s e
706−
707− host = Text.decodeUtf8 (Client.host rq)
708− path = Text.decodeUtf8 (Client.path rq)
709−
710−parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
711−parseLBS = either (Left . Text.pack) Right . eitherDecode'
712−
713−base64Encode :: [Pair] -> ByteString
714−base64Encode = base64 . LBS.toStrict . encode . object
715−
716−base64 :: ByteArray a => a -> ByteString
717−base64 = convertToBase Base64URLUnpadded
718−
719−buildBody :: Builder -> RequestBody
720−buildBody = RequestBodyLBS . Build.toLazyByteString
721−
722−buildText :: ToText a => a -> Builder
723−buildText = build . toText
724−
725−queryEncodeScopes :: [OAuthScope] -> Build.Builder
726−queryEncodeScopes =
727− mconcat
728− . intersperse "+"
729− . map (urlEncodeBuilder True . Text.encodeUtf8)
730− . coerce
731−
732−concatScopes :: [OAuthScope] -> LText.Text
733−concatScopes =
734− TBuild.toLazyText
735− . mconcat
736− . intersperse " "
737− . map TBuild.fromText
738− . coerce
739−
740−data RefreshError = RefreshError
741− { _error :: !Text
742− , _description :: !(Maybe Text)
743− }
744−
745−instance FromJSON RefreshError where
746− parseJSON = withObject "refresh_error" $ \o -> RefreshError
747− <$> o .: "error"
748− <*> o .:? "error_description"
gogol/src/Network/Google/Auth/ApplicationDefaultCredentials.hsnew file+133
@@ -0,0 +1,133 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+
4+-- |
5+-- Module : Network.Google.Auth.ApplicationDefaultCredentials
6+-- Copyright : (c) 2015 Brendan Hay
7+-- License : Mozilla Public License, v. 2.0.
8+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
9+-- Stability : provisional
10+-- Portability : non-portable (GHC extensions)
11+
12+module Network.Google.Auth.ApplicationDefaultCredentials where
13+
14+import Control.Applicative
15+import Control.Concurrent
16+import Control.Exception.Lens
17+import Control.Lens hiding (coerce, (.=))
18+import Control.Monad
19+import Control.Monad.Catch
20+import Control.Monad.IO.Class
21+import Crypto.Hash.Algorithms (SHA256 (..))
22+import Crypto.PubKey.RSA.PKCS15 (signSafer)
23+import Crypto.PubKey.RSA.Types (PrivateKey)
24+import Data.Aeson
25+import Data.Aeson.Types
26+import Data.ByteArray
27+import Data.ByteArray.Encoding
28+import Data.ByteString (ByteString)
29+import Data.ByteString.Builder (Builder)
30+import qualified Data.ByteString.Builder as Build
31+import qualified Data.ByteString.Char8 as BS8
32+import qualified Data.ByteString.Lazy as LBS
33+import Data.Coerce
34+import Data.Default.Class (def)
35+import Data.List (intersperse)
36+import Data.String
37+import qualified Data.Text as Text
38+import qualified Data.Text.Encoding as Text
39+import qualified Data.Text.Lazy as LText
40+import qualified Data.Text.Lazy.Builder as TBuild
41+import qualified Data.Text.Lazy.Encoding as LText
42+import Data.Time
43+import Data.Time.Clock.POSIX
44+import Data.Typeable
45+import Data.X509
46+import Data.X509.Memory
47+import Network.Google.Compute.Metadata
48+import Network.Google.Internal.Auth
49+import Network.Google.Internal.Logger
50+import Network.Google.Prelude hiding (buildText)
51+import Network.HTTP.Conduit hiding (Request)
52+import qualified Network.HTTP.Conduit as Client
53+import Network.HTTP.Types
54+import System.Directory (doesFileExist,
55+ getHomeDirectory)
56+import System.Environment (lookupEnv)
57+import System.FilePath ((</>))
58+import System.Info (os)
59+
60+-- | The environment variable name which is used to specify the directory
61+-- containing the @application_default_credentials.json@ generated by @gcloud init@.
62+cloudSDKConfigDir :: String
63+cloudSDKConfigDir = "CLOUDSDK_CONFIG"
64+
65+-- | The environment variable pointing the file with local
66+-- Application Default Credentials.
67+defaultCredentialsFile :: String
68+defaultCredentialsFile = "GOOGLE_APPLICATION_CREDENTIALS"
69+
70+{-| Authorized User credentials which are typically generated by the Cloud SDK
71+Tools such as @gcloud init@, of the following form:
72+
73+@
74+{
75+ \"type\": \"authorized_user\",
76+ \"client_id\": \"32555940559.apps.googleusercontent.com\",
77+ \"client_secret\": \"Zms2qjJy2998hD4CTg2ejr2\",
78+ \"refresh_token\": \"1/B3gM1x35v.VtqffS1n5w-rSJ\"
79+}
80+@
81+
82+The secret and refresh token are used to obtain a valid 'OAuthToken' from
83+'accountsURL' using grant_type @refresh_token@.
84+-}
85+data AuthorizedUser = AuthorizedUser
86+ { _userId :: !ClientId
87+ , _userRefresh :: !RefreshToken
88+ , _userSecret :: !Secret
89+ } deriving (Eq, Show)
90+
91+instance FromJSON AuthorizedUser where
92+ parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser
93+ <$> o .: "client_id"
94+ <*> o .: "refresh_token"
95+ <*> o .: "client_secret"
96+
97+authorizedUserToken :: (MonadIO m, MonadCatch m)
98+ => AuthorizedUser
99+ -> Maybe RefreshToken
100+ -> Logger
101+ -> Manager
102+ -> m OAuthToken
103+authorizedUserToken u r = refreshRequest $
104+ accountsRequest
105+ { Client.requestBody = textBody $
106+ "grant_type=refresh_token"
107+ <> "&client_id=" <> toText (_userId u)
108+ <> "&client_secret=" <> toText (_userSecret u)
109+ <> "&refresh_token=" <> toText (fromMaybe (_userRefresh u) r)
110+ }
111+
112+-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
113+-- default application credentials filepath.
114+defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
115+defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile)
116+
117+-- | Return the filepath to the Cloud SDK well known file location such as
118+-- @~\/.config\/gcloud\/application_default_credentials.json@.
119+cloudSDKConfigPath :: MonadIO m => m FilePath
120+cloudSDKConfigPath = do
121+ m <- liftIO (lookupEnv cloudSDKConfigDir)
122+ case m of
123+ Just d -> pure $! d </> "application_default_credentials.json"
124+ Nothing -> do
125+ d <- getConfigDirectory
126+ pure $! d </> "gcloud/application_default_credentials.json"
127+
128+getConfigDirectory :: MonadIO m => m FilePath
129+getConfigDirectory = do
130+ h <- liftIO getHomeDirectory
131+ if os == "windows"
132+ then pure h
133+ else pure $! h </> ".config"
gogol/src/Network/Google/Auth/Device.hsnew file+56
@@ -0,0 +1,56 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- |
4+-- Module : Network.Google.Auth.Device
5+-- Copyright : (c) 2015 Brendan Hay
6+-- License : Mozilla Public License, v. 2.0.
7+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
8+-- Stability : provisional
9+-- Portability : non-portable (GHC extensions)
10+
11+module Network.Google.Auth.Device where
12+
13+import Control.Applicative
14+import Control.Concurrent
15+import Control.Exception.Lens
16+import Control.Lens hiding (coerce, (.=))
17+import Control.Monad
18+import Control.Monad.Catch
19+import Control.Monad.IO.Class
20+import Crypto.Hash.Algorithms (SHA256 (..))
21+import Crypto.PubKey.RSA.PKCS15 (signSafer)
22+import Crypto.PubKey.RSA.Types (PrivateKey)
23+import Data.Aeson
24+import Data.Aeson.Types
25+import Data.ByteArray
26+import Data.ByteArray.Encoding
27+import Data.ByteString (ByteString)
28+import Data.ByteString.Builder (Builder)
29+import qualified Data.ByteString.Builder as Build
30+import qualified Data.ByteString.Char8 as BS8
31+import qualified Data.ByteString.Lazy as LBS
32+import Data.Coerce
33+import Data.Default.Class (def)
34+import Data.List (intersperse)
35+import Data.String
36+import qualified Data.Text as Text
37+import qualified Data.Text.Encoding as Text
38+import qualified Data.Text.Lazy as LText
39+import qualified Data.Text.Lazy.Builder as TBuild
40+import qualified Data.Text.Lazy.Encoding as LText
41+import Data.Time
42+import Data.Time.Clock.POSIX
43+import Data.Typeable
44+import Data.X509
45+import Data.X509.Memory
46+import Network.Google.Compute.Metadata
47+import Network.Google.Internal.Logger
48+import Network.Google.Prelude hiding (buildText)
49+import Network.HTTP.Conduit hiding (Request)
50+import qualified Network.HTTP.Conduit as Client
51+import Network.HTTP.Types
52+import System.Directory (doesFileExist,
53+ getHomeDirectory)
54+import System.Environment (lookupEnv)
55+import System.FilePath ((</>))
56+import System.Info (os)
gogol/src/Network/Google/Auth/InstalledApplication.hsnew file+96
@@ -0,0 +1,96 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- |
4+-- Module : Network.Google.Auth.InstalledApplication
5+-- Copyright : (c) 2015 Brendan Hay
6+-- License : Mozilla Public License, v. 2.0.
7+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
8+-- Stability : provisional
9+-- Portability : non-portable (GHC extensions)
10+
11+module Network.Google.Auth.InstalledApplication where
12+
13+import Control.Applicative
14+import Control.Concurrent
15+import Control.Exception.Lens
16+import Control.Lens hiding (coerce, (.=))
17+import Control.Monad
18+import Control.Monad.Catch
19+import Control.Monad.IO.Class
20+import Crypto.Hash.Algorithms (SHA256 (..))
21+import Crypto.PubKey.RSA.PKCS15 (signSafer)
22+import Crypto.PubKey.RSA.Types (PrivateKey)
23+import Data.Aeson
24+import Data.Aeson.Types
25+import Data.ByteArray
26+import Data.ByteArray.Encoding
27+import Data.ByteString (ByteString)
28+import Data.ByteString.Builder (Builder)
29+import qualified Data.ByteString.Builder as Build
30+import qualified Data.ByteString.Char8 as BS8
31+import qualified Data.ByteString.Lazy as LBS
32+import Data.Coerce
33+import Data.Default.Class (def)
34+import Data.List (intersperse)
35+import Data.String
36+import qualified Data.Text as Text
37+import qualified Data.Text.Encoding as Text
38+import qualified Data.Text.Lazy as LText
39+import qualified Data.Text.Lazy.Builder as TBuild
40+import qualified Data.Text.Lazy.Encoding as LText
41+import Data.Time
42+import Data.Time.Clock.POSIX
43+import Data.Typeable
44+import Data.X509
45+import Data.X509.Memory
46+import Network.Google.Internal.Auth
47+import Network.Google.Internal.Logger
48+import Network.Google.Prelude
49+import Network.HTTP.Conduit hiding (Request)
50+import qualified Network.HTTP.Conduit as Client
51+import Network.HTTP.Types
52+
53+-- | Given a client identifier, client secret, and a list of scopes to authorize,
54+-- construct a URL that can be used to obtain the 'OAuthCode' required to
55+-- instantiate 'FromClient'-style credentials.
56+formURL :: OAuthClient -> [OAuthScope] -> Text
57+formURL c ss = accountsURL
58+ <> "?response_type=code"
59+ <> "&client_id=" <> toText (_clientId c)
60+ <> "&redirect_uri=" <> redirectURI
61+ <> "&scope=" <> Text.decodeUtf8 (queryEncodeScopes ss)
62+
63+-- | @urn:ietf:wg:oauth:2.0:oob@.
64+redirectURI :: Text
65+redirectURI = "urn:ietf:wg:oauth:2.0:oob"
66+
67+exchangeCode :: (MonadIO m, MonadCatch m)
68+ => OAuthClient
69+ -> OAuthCode
70+ -> Logger
71+ -> Manager
72+ -> m OAuthToken
73+exchangeCode c n = refreshRequest $
74+ accountsRequest
75+ { Client.requestBody = textBody $
76+ "grant_type=authorization_code"
77+ <> "&client_id=" <> toText (_clientId c)
78+ <> "&client_secret=" <> toText (_clientSecret c)
79+ <> "&code=" <> toText n
80+ <> "&redirect_uri=" <> redirectURI
81+ }
82+
83+refreshToken :: (MonadIO m, MonadCatch m)
84+ => OAuthClient
85+ -> OAuthToken
86+ -> Logger
87+ -> Manager
88+ -> m OAuthToken
89+refreshToken c t = refreshRequest $
90+ accountsRequest
91+ { Client.requestBody = textBody $
92+ "grant_type=refresh_token"
93+ <> "&client_id=" <> toText (_clientId c)
94+ <> "&client_secret=" <> toText (_clientSecret c)
95+ <> maybe mempty ("&refresh_token=" <>) (toText <$> _tokenRefresh t)
96+ }
gogol/src/Network/Google/Auth/ServiceAccount.hsnew file+164
@@ -0,0 +1,164 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- |
4+-- Module : Network.Google.Auth.ServiceAccount
5+-- Copyright : (c) 2015 Brendan Hay
6+-- License : Mozilla Public License, v. 2.0.
7+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
8+-- Stability : provisional
9+-- Portability : non-portable (GHC extensions)
10+
11+module Network.Google.Auth.ServiceAccount where
12+
13+import Control.Applicative
14+import Control.Concurrent
15+import Control.Exception.Lens
16+import Control.Lens hiding (coerce, (.=))
17+import Control.Monad
18+import Control.Monad.Catch
19+import Control.Monad.IO.Class
20+import Crypto.Hash.Algorithms (SHA256 (..))
21+import Crypto.PubKey.RSA.PKCS15 (signSafer)
22+import Crypto.PubKey.RSA.Types (PrivateKey)
23+import Data.Aeson
24+import Data.Aeson.Types
25+import Data.ByteArray
26+import Data.ByteArray.Encoding
27+import Data.ByteString (ByteString)
28+import Data.ByteString.Builder (Builder)
29+import qualified Data.ByteString.Builder as Build
30+import qualified Data.ByteString.Char8 as BS8
31+import qualified Data.ByteString.Lazy as LBS
32+import Data.Coerce
33+import Data.Default.Class (def)
34+import Data.List (intersperse)
35+import Data.String
36+import qualified Data.Text as Text
37+import qualified Data.Text.Encoding as Text
38+import qualified Data.Text.Lazy as LText
39+import qualified Data.Text.Lazy.Builder as TBuild
40+import qualified Data.Text.Lazy.Encoding as LText
41+import Data.Time
42+import Data.Time.Clock.POSIX
43+import Data.Typeable
44+import Data.X509
45+import Data.X509.Memory
46+import Network.Google.Compute.Metadata
47+import Network.Google.Internal.Auth
48+import Network.Google.Internal.Logger
49+import Network.Google.Prelude hiding (buildText)
50+import Network.HTTP.Conduit hiding (Request)
51+import qualified Network.HTTP.Conduit as Client
52+import Network.HTTP.Types
53+import System.Directory (doesFileExist,
54+ getHomeDirectory)
55+import System.Environment (lookupEnv)
56+import System.FilePath ((</>))
57+import System.Info (os)
58+
59+-- | 1 hour in seconds.
60+maxTokenLifetimeSeconds :: Int
61+maxTokenLifetimeSeconds = 3600
62+
63+{-| Service Account credentials which are typically generated/download
64+from the Google Developer console of the following form:
65+
66+@
67+{
68+ \"type\": \"service_account\",
69+ \"private_key_id\": \"303ad77e5efdf2ce952DFa\",
70+ \"private_key\": \"-----BEGIN PRIVATE KEY-----\n...\n\",
71+ \"client_email\": \"email@serviceaccount.com\",
72+ \"client_id\": \"035-2-310.useraccount.com\"
73+}
74+@
75+
76+The private key is used to sign a JSON Web Token (JWT) of the
77+grant_type @urn:ietf:params:oauth:grant-type:jwt-bearer@, which is sent to
78+'accountsURL' to obtain a valid 'OAuthToken'. This process requires explicitly
79+specifying which 'Scope's the resulting 'OAuthToken' is authorized to access.
80+-}
81+data ServiceAccount = ServiceAccount
82+ { _serviceId :: !ClientId
83+ , _serviceEmail :: !Text
84+ , _serviceKeyId :: !Text
85+ , _servicePrivateKey :: !PrivateKey
86+ } deriving (Eq, Show)
87+
88+instance FromJSON ServiceAccount where
89+ parseJSON = withObject "service_account" $ \o -> do
90+ bs <- Text.encodeUtf8 <$> o .: "private_key"
91+ k <- case listToMaybe (readKeyFileFromMemory bs) of
92+ Just (PrivKeyRSA k) -> pure k
93+ _ ->
94+ fail "Unable to parse key contents from \"private_key\""
95+ ServiceAccount
96+ <$> o .: "client_id"
97+ <*> o .: "client_email"
98+ <*> o .: "private_key_id"
99+ <*> pure k
100+
101+serviceAccountToken :: (MonadIO m, MonadCatch m)
102+ => ServiceAccount
103+ -> [OAuthScope]
104+ -> Logger
105+ -> Manager
106+ -> m OAuthToken
107+serviceAccountToken s ss l m = do
108+ b <- encodeBearerJWT s ss
109+ let rq = accountsRequest
110+ { Client.requestBody = RequestBodyBS $
111+ "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"
112+ <> "&assertion="
113+ <> b
114+ }
115+ refreshRequest rq l m
116+
117+metadataToken :: (MonadIO m, MonadCatch m)
118+ => ServiceId
119+ -> Logger
120+ -> Manager
121+ -> m OAuthToken
122+metadataToken s = refreshRequest $
123+ metadataRequest
124+ { Client.path = "instance/service-accounts/"
125+ <> Text.encodeUtf8 (toText s)
126+ <> "/token"
127+ }
128+
129+encodeBearerJWT :: (MonadIO m, MonadThrow m)
130+ => ServiceAccount
131+ -> [OAuthScope]
132+ -> m ByteString
133+encodeBearerJWT s ss = liftIO $ do
134+ i <- input . truncate <$> getPOSIXTime
135+ r <- signSafer (Just SHA256) (_servicePrivateKey s) i
136+ either failure (pure . concat' i) r
137+ where
138+ concat' i x = i <> "." <> signature (base64 x)
139+
140+ failure e = throwM $
141+ TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing
142+
143+ signature bs =
144+ case BS8.unsnoc bs of
145+ Nothing -> mempty
146+ Just (bs', x)
147+ | x == '=' -> bs'
148+ | otherwise -> bs
149+
150+ input n = header <> "." <> payload
151+ where
152+ header = base64Encode
153+ [ "alg" .= ("RS256" :: Text)
154+ , "typ" .= ("JWT" :: Text)
155+ , "kid" .= _serviceKeyId s
156+ ]
157+
158+ payload = base64Encode
159+ [ "aud" .= accountsURL
160+ , "scope" .= concatScopes ss
161+ , "iat" .= n
162+ , "exp" .= (n + maxTokenLifetimeSeconds)
163+ , "iss" .= _serviceEmail s
164+ ]
gogol/src/Network/Google/Compute/Metadata.hs+8−9
@@ -69,15 +69,6 @@ metadataFlavorHeader = "Metadata-Flavor"
69metadataFlavorDesired :: ByteString
69metadataFlavorDesired :: ByteString
70metadataFlavorDesired = "Google"
70metadataFlavorDesired = "Google"
71
71
72−metadataRequest :: Client.Request
73−metadataRequest = def
74− { Client.host = "metadata.google.internal"
75− , Client.port = 80
76− , Client.secure = False
77− , Client.method = "GET"
78− , Client.requestHeaders = [(metadataFlavorHeader, metadataFlavorDesired)]
79− }
80−
81-- | Detect if the underlying host is running on GCE.
72-- | Detect if the underlying host is running on GCE.
82--
73--
83-- The environment variable @NO_GCE_CHECK@ can be set to @1@, @true@, @yes@, or @on@
74-- The environment variable @NO_GCE_CHECK@ can be set to @1@, @true@, @yes@, or @on@
@@ -243,3 +234,11 @@ metadata path ss m =
243 else Just . toException $ StatusCodeException s hs cj
234 else Just . toException $ StatusCodeException s hs cj
244 }
235 }
245
236
237+metadataRequest :: Client.Request
238+metadataRequest = def
239+ { Client.host = "metadata.google.internal"
240+ , Client.port = 80
241+ , Client.secure = False
242+ , Client.method = "GET"
243+ , Client.requestHeaders = [(metadataFlavorHeader, metadataFlavorDesired)]
244+ }
gogol/src/Network/Google/Env.hs+9−8
@@ -22,8 +22,8 @@ import Network.HTTP.Conduit
22
22
23-- | The environment containing the parameters required to make Google requests.
23-- | The environment containing the parameters required to make Google requests.
24data Env = Env
24data Env = Env
25− { _envLogger :: !Logger
26− , _envOverride :: !(Dual (Endo Service))
25+ { _envOverride :: !(Dual (Endo Service))
26+ , _envLogger :: !Logger
27 , _envManager :: !Manager
27 , _envManager :: !Manager
28 , _envStore :: !Store
28 , _envStore :: !Store
29 }
29 }
@@ -35,20 +35,20 @@ class HasEnv a where
35 environment :: Lens' a Env
35 environment :: Lens' a Env
36 {-# MINIMAL environment #-}
36 {-# MINIMAL environment #-}
37
37
38− -- | The function used to output log messages.
39− envLogger :: Lens' a Logger
40−
41 -- | The currently applied overrides to all 'Service' configuration.
38 -- | The currently applied overrides to all 'Service' configuration.
42 envOverride :: Lens' a (Dual (Endo Service))
39 envOverride :: Lens' a (Dual (Endo Service))
43
40
41+ -- | The function used to output log messages.
42+ envLogger :: Lens' a Logger
43+
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 credential store used to sign requests for authentication with Google.
47 -- | The credential store used to sign requests for authentication with Google.
48 envStore :: Lens' a Store
48 envStore :: Lens' a Store
49
49
50− envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a })
51 envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })
50 envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })
51+ envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a })
52 envManager = environment . lens _envManager (\s a -> s { _envManager = a })
52 envManager = environment . lens _envManager (\s a -> s { _envManager = a })
53 envStore = environment . lens _envStore (\s a -> s { _envStore = a })
53 envStore = environment . lens _envStore (\s a -> s { _envStore = a })
54
54
@@ -117,7 +117,7 @@ newEnv :: (MonadIO m, MonadCatch m) => [OAuthScope] -> m Env
117newEnv ss = do
117newEnv ss = do
118 m <- liftIO (newManager tlsManagerSettings)
118 m <- liftIO (newManager tlsManagerSettings)
119 c <- discover ss m
119 c <- discover ss m
120− newEnvWith c m
120+ newEnvWith c (\_ _ -> pure ()) m
121
121
122-- | Creates a new environment without logging, using the supplied 'Manager' and
122-- | Creates a new environment without logging, using the supplied 'Manager' and
123-- credentials. Use either the 'Credentials' constructor or
123-- credentials. Use either the 'Credentials' constructor or
@@ -135,6 +135,7 @@ newEnv ss = do
135-- /See:/ 'newEnv'.
135-- /See:/ 'newEnv'.
136newEnvWith :: (MonadIO m, MonadCatch m)
136newEnvWith :: (MonadIO m, MonadCatch m)
137 => Credentials
137 => Credentials
138+ -> Logger
138 -> Manager
139 -> Manager
139 -> m Env
140 -> m Env
140−newEnvWith c m = Env (\_ _ -> pure ()) mempty m <$> emptyStore c
141+newEnvWith c l m = Env mempty l m <$> initStore c l m
gogol/src/Network/Google/Internal/Auth.hsnew file+252
@@ -0,0 +1,252 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+
9+-- |
10+-- Module : Network.Google.Internal.Auth
11+-- Copyright : (c) 2015 Brendan Hay
12+-- License : Mozilla Public License, v. 2.0.
13+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
14+-- Stability : provisional
15+-- Portability : non-portable (GHC extensions)
16+
17+module Network.Google.Internal.Auth where
18+
19+import Control.Applicative
20+import Control.Concurrent
21+import Control.Exception.Lens
22+import Control.Lens hiding (coerce, (.=))
23+import Control.Monad
24+import Control.Monad.Catch
25+import Control.Monad.IO.Class
26+import Crypto.Hash.Algorithms (SHA256 (..))
27+import Crypto.PubKey.RSA.PKCS15 (signSafer)
28+import Crypto.PubKey.RSA.Types (PrivateKey)
29+import Data.Aeson
30+import Data.Aeson.Types
31+import Data.ByteArray
32+import Data.ByteArray.Encoding
33+import Data.ByteString (ByteString)
34+import Data.ByteString.Builder (Builder)
35+import qualified Data.ByteString.Builder as Build
36+import qualified Data.ByteString.Char8 as BS8
37+import qualified Data.ByteString.Lazy as LBS
38+import Data.Coerce
39+import Data.Default.Class (def)
40+import Data.List (intersperse)
41+import Data.String
42+import qualified Data.Text as Text
43+import qualified Data.Text.Encoding as Text
44+import qualified Data.Text.Lazy as LText
45+import qualified Data.Text.Lazy.Builder as TBuild
46+import qualified Data.Text.Lazy.Encoding as LText
47+import Data.Time
48+import Data.Time.Clock.POSIX
49+import Data.Typeable
50+import Data.X509
51+import Data.X509.Memory
52+import Network.Google.Compute.Metadata
53+import Network.Google.Internal.Logger
54+import Network.Google.Prelude hiding (buildText)
55+import Network.HTTP.Conduit hiding (Request)
56+import qualified Network.HTTP.Conduit as Client
57+import Network.HTTP.Types
58+import System.Directory (doesFileExist,
59+ getHomeDirectory)
60+import System.Environment (lookupEnv)
61+import System.FilePath ((</>))
62+import System.Info (os)
63+
64+-- | A client identifier and accompanying secret used to obtain/refresh a token.
65+data OAuthClient = OAuthClient
66+ { _clientId :: !ClientId
67+ , _clientSecret :: !Secret
68+ } deriving (Eq, Show)
69+
70+{-| An OAuth bearer type token of the following form:
71+
72+@
73+{
74+ \"token_type\": \"Bearer\",
75+ \"access_token\": \"eyJhbGci...\",
76+ \"refresh_token\": \"1/B3gq9K...\",
77+ \"expires_in\": 3600,
78+ ...
79+}
80+@
81+
82+The '_tokenAccess' field will be inserted verbatim into the
83+@Authorization: Bearer ...@ header for all HTTP requests.
84+-}
85+data OAuthToken = OAuthToken
86+ { _tokenAccess :: !AccessToken
87+ , _tokenRefresh :: !(Maybe RefreshToken)
88+ , _tokenExpiry :: !UTCTime
89+ } deriving (Eq, Show)
90+
91+instance FromJSON (UTCTime -> OAuthToken) where
92+ parseJSON = withObject "bearer" $ \o -> do
93+ t <- o .: "access_token"
94+ r <- o .:? "refresh_token"
95+ e <- o .: "expires_in" <&> fromInteger
96+ pure (OAuthToken t r . addUTCTime e)
97+
98+newtype OAuthCode = OAuthCode Text
99+ deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
100+
101+-- | An error thrown when attempting to read AuthN/AuthZ information.
102+data AuthError
103+ = RetrievalError HttpException
104+ | MissingFileError FilePath
105+ | InvalidFileError FilePath Text
106+ | TokenRefreshError Status Text (Maybe Text)
107+ deriving (Show, Typeable)
108+
109+instance Exception AuthError
110+
111+class AsAuthError a where
112+ -- | A general authentication error.
113+ _AuthError :: Prism' a AuthError
114+ {-# MINIMAL _AuthError #-}
115+
116+ -- | An error occured while communicating over HTTP with either then
117+ -- local metadata or remote accounts.google.com endpoints.
118+ _RetrievalError :: Prism' a HttpException
119+
120+ -- | The specified default credentials file could not be found.
121+ _MissingFileError :: Prism' a FilePath
122+
123+ -- | An error occured parsing the default credentials file.
124+ _InvalidFileError :: Prism' a (FilePath, Text)
125+
126+ -- | An error occured when attempting to refresh a token.
127+ _TokenRefreshError :: Prism' a (Status, Text, Maybe Text)
128+
129+ _RetrievalError = _AuthError . _RetrievalError
130+ _MissingFileError = _AuthError . _MissingFileError
131+ _InvalidFileError = _AuthError . _InvalidFileError
132+ _TokenRefreshError = _AuthError . _TokenRefreshError
133+
134+instance AsAuthError SomeException where
135+ _AuthError = exception
136+
137+instance AsAuthError AuthError where
138+ _AuthError = id
139+
140+ _RetrievalError = prism RetrievalError $ \case
141+ RetrievalError e -> Right e
142+ x -> Left x
143+
144+ _MissingFileError = prism MissingFileError $ \case
145+ MissingFileError f -> Right f
146+ x -> Left x
147+
148+ _InvalidFileError = prism
149+ (uncurry InvalidFileError)
150+ (\case
151+ InvalidFileError f e -> Right (f, e)
152+ x -> Left x)
153+
154+ _TokenRefreshError = prism
155+ (\(s, e, d) -> TokenRefreshError s e d)
156+ (\case
157+ TokenRefreshError s e d -> Right (s, e, d)
158+ x -> Left x)
159+
160+data RefreshError = RefreshError
161+ { _error :: !Text
162+ , _description :: !(Maybe Text)
163+ }
164+
165+instance FromJSON RefreshError where
166+ parseJSON = withObject "refresh_error" $ \o -> RefreshError
167+ <$> o .: "error"
168+ <*> o .:? "error_description"
169+
170+-- | @https://accounts.google.com/o/oauth2/token@.
171+accountsURL :: Text
172+accountsURL = "https://accounts.google.com/o/oauth2/token"
173+
174+accountsRequest :: Client.Request
175+accountsRequest = def
176+ { Client.host = "accounts.google.com"
177+ , Client.port = 443
178+ , Client.secure = True
179+ , Client.checkStatus = \_ _ _ -> Nothing
180+ , Client.method = "POST"
181+ , Client.path = "/o/oauth2/token"
182+ , Client.requestHeaders =
183+ [ (hContentType, "application/x-www-form-urlencoded")
184+ ]
185+ }
186+
187+refreshRequest :: (MonadIO m, MonadCatch m)
188+ => Client.Request
189+ -> Logger
190+ -> Manager
191+ -> m OAuthToken
192+refreshRequest rq l m = do
193+ logDebug l rq -- debug:ClientRequest
194+
195+ rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)
196+
197+ let bs = responseBody rs
198+ s = responseStatus rs
199+
200+ logDebug l rs -- debug:ClientResponse
201+ logTrace l $ "[Response Body]\n" <> bs -- trace:ResponseBody
202+
203+ if fromEnum s == 200
204+ then success s bs
205+ else failure s bs
206+ where
207+ success s bs = do
208+ f <- parseErr s bs
209+ ts <- liftIO getCurrentTime
210+ pure (f ts)
211+
212+ failure s bs = do
213+ let e = "Failure refreshing token from " <> host <> path
214+ logError l $ "[Refresh Error] " <> build e
215+ case parseLBS bs of
216+ Right x -> refreshErr s (_error x) (_description x)
217+ Left _ -> refreshErr s e Nothing
218+
219+ parseErr s bs =
220+ case parseLBS bs of
221+ Right !x -> pure x
222+ Left e -> do
223+ logError l $
224+ "[Parse Error] Failure parsing token refresh " <> build e
225+ refreshErr s e Nothing
226+
227+ refreshErr :: MonadThrow m => Status -> Text -> Maybe Text -> m a
228+ refreshErr s e = throwM . TokenRefreshError s e
229+
230+ host = Text.decodeUtf8 (Client.host rq)
231+ path = Text.decodeUtf8 (Client.path rq)
232+
233+parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
234+parseLBS = either (Left . Text.pack) Right . eitherDecode'
235+
236+base64Encode :: [Pair] -> ByteString
237+base64Encode = base64 . LBS.toStrict . encode . object
238+
239+base64 :: ByteArray a => a -> ByteString
240+base64 = convertToBase Base64URLUnpadded
241+
242+queryEncodeScopes :: [OAuthScope] -> ByteString
243+queryEncodeScopes =
244+ BS8.intercalate "+"
245+ . map (urlEncode True . Text.encodeUtf8)
246+ . coerce
247+
248+concatScopes :: [OAuthScope] -> Text
249+concatScopes = Text.intercalate " " . coerce
250+
251+textBody :: Text -> RequestBody
252+textBody = RequestBodyBS . Text.encodeUtf8