git.iko.soy/gogol
on develop help sign in
Splitting authentication into separate modules
c50d087Brendan 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+154−623
@@ -19,334 +19,148 @@
19--
19--
20-- Explicitly specify your Google credentials, or retrieve them
20-- Explicitly specify your Google credentials, or retrieve them
21-- from the underlying OS.
21-- from the underlying OS.
22−module Network.Google.Auth
22+module Network.Google.Auth where
23− (
23+ -- (
24− -- * Credentials
24+ -- -- * Credentials
25− Credentials (..)
25+ -- Credentials (..)
26−
26+
27− -- ** Discovery
27+ -- -- ** Discovery
28− , discover
28+ -- , discover
29− , fromFile
29+ -- , fromFile
30− , fromFilePath
30+ -- , fromFilePath
31− , fromJSONCredentials
31+ -- , fromJSONCredentials
32−
32+
33− -- ** Thread-safe Storage
33+ -- -- ** Thread-safe Storage
34− , Auth (..)
34+ -- , Auth (..)
35− , Store
35+ -- , Store
36− , emptyStore
36+ -- , emptyStore
37−
37+
38− -- ** Authorizing Requests
38+ -- -- ** Authorizing Requests
39− , authorize
39+ -- , authorize
40−
40+
41− -- ** Constructing Callback URLs
41+ -- -- ** Constructing Callback URLs
42− , formURL
42+ -- , formURL
43− , redirectURI
43+ -- , redirectURI
44− , accountsURL
44+ -- , accountsURL
45−
45+
46− -- ** Default Constants
46+ -- -- ** Default Constants
47− -- *** Google Compute Engine
47+ -- -- *** Google Compute Engine
48− , checkGCEVar
48+ -- , checkGCEVar
49−
49+
50− -- *** Cloud SDK
50+ -- -- *** Cloud SDK
51− , cloudSDKConfigDir
51+ -- , cloudSDKConfigDir
52− , cloudSDKConfigPath
52+ -- , cloudSDKConfigPath
53−
53+
54− -- *** Application Default Credentials
54+ -- -- *** Application Default Credentials
55− , defaultCredentialsFile
55+ -- , defaultCredentialsFile
56− , defaultCredentialsPath
56+ -- , defaultCredentialsPath
57−
57+
58− -- ** Handling Errors
58+ -- -- ** Handling Errors
59− , AsAuthError (..)
59+ -- , AsAuthError (..)
60− , AuthError (..)
60+ -- , AuthError (..)
61−
61+
62− -- * Credential Types
62+ -- -- * Credential Types
63− , ServiceAccount (..)
63+ -- , ServiceAccount (..)
64− , AuthorizedUser (..)
64+ -- , AuthorizedUser (..)
65−
65+
66− -- * OAuth Types
66+ -- -- * OAuth Types
67− , OAuthClient (..)
67+ -- , OAuthClient (..)
68− , OAuthToken (..)
68+ -- , OAuthToken (..)
69− , OAuthCode (..)
69+ -- , OAuthCode (..)
70− , OAuthScope (..)
70+ -- , OAuthScope (..)
71−
71+
72− -- * Re-exported Types
72+ -- -- * Re-exported Types
73− , AccessToken (..)
73+ -- , AccessToken (..)
74− , RefreshToken (..)
74+ -- , RefreshToken (..)
75− , Secret (..)
75+ -- , Secret (..)
76− , ServiceId (..)
76+ -- , ServiceId (..)
77− , ClientId (..)
77+ -- , ClientId (..)
78−
78+
79− -- * Exchange and Refresh Internals
79+ -- -- * Exchange and Refresh Internals
80− , getToken
80+ -- , getToken
81− , validateToken
81+ -- , validateToken
82−
82+
83− , exchange
83+ -- , exchange
84− , exchangeCode
84+ -- , exchangeCode
85−
85+
86− , refresh
86+ -- , refresh
87− , refreshMetadata
87+ -- , refreshMetadata
88− , refreshToken
88+ -- , refreshToken
89− , refreshAssertion
89+ -- , refreshAssertion
90− ) where
90+ -- ) where
91
91
92import Control.Applicative
92import Control.Applicative
93import Control.Concurrent
93import Control.Concurrent
94import Control.Exception.Lens
94import Control.Exception.Lens
95−import Control.Lens hiding (coerce, (.=))
95+import Control.Lens hiding
96+ (coerce,
97+ (.=))
96import Control.Monad
98import Control.Monad
97import Control.Monad.Catch
99import Control.Monad.Catch
98import Control.Monad.IO.Class
100import Control.Monad.IO.Class
99−import Crypto.Hash.Algorithms (SHA256 (..))
101+import Crypto.Hash.Algorithms (SHA256 (..))
100−import Crypto.PubKey.RSA.PKCS15 (signSafer)
102+import Crypto.PubKey.RSA.PKCS15 (signSafer)
101−import Crypto.PubKey.RSA.Types (PrivateKey)
103+import Crypto.PubKey.RSA.Types (PrivateKey)
102import Data.Aeson
104import Data.Aeson
103import Data.Aeson.Types
105import Data.Aeson.Types
104import Data.ByteArray
106import Data.ByteArray
105import Data.ByteArray.Encoding
107import Data.ByteArray.Encoding
106−import Data.ByteString (ByteString)
108+import Data.ByteString (ByteString)
107−import Data.ByteString.Builder (Builder)
109+import Data.ByteString.Builder (Builder)
108−import qualified Data.ByteString.Builder as Build
110+import qualified Data.ByteString.Builder as Build
109−import qualified Data.ByteString.Char8 as BS8
111+import qualified Data.ByteString.Char8 as BS8
110−import qualified Data.ByteString.Lazy as LBS
112+import qualified Data.ByteString.Lazy as LBS
111import Data.Coerce
113import Data.Coerce
112−import Data.Default.Class (def)
114+import Data.Default.Class (def)
113−import Data.List (intersperse)
115+import Data.List (intersperse)
114import Data.String
116import Data.String
115−import qualified Data.Text as Text
117+import qualified Data.Text as Text
116−import qualified Data.Text.Encoding as Text
118+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
119import Data.Time
121import Data.Time.Clock.POSIX
120import Data.Time.Clock.POSIX
122import Data.Typeable
121import Data.Typeable
123import Data.X509
122import Data.X509
124import Data.X509.Memory
123import Data.X509.Memory
124+import Network.Google.Auth.ApplicationDefaultCredentials
125+import Network.Google.Auth.Device
126+import Network.Google.Auth.InstalledApplication
127+import Network.Google.Auth.ServiceAccount
125import Network.Google.Compute.Metadata
128import Network.Google.Compute.Metadata
129+import Network.Google.Internal.Auth
126import Network.Google.Internal.Logger
130import Network.Google.Internal.Logger
127−import Network.Google.Prelude hiding (buildText)
131+import Network.Google.Prelude
128−import Network.HTTP.Conduit hiding (Request)
132+import Network.HTTP.Conduit hiding
133+ (Request)
129−import qualified Network.HTTP.Conduit as Client
134+import qualified Network.HTTP.Conduit as Client
130import Network.HTTP.Types
135import Network.HTTP.Types
131−import System.Directory (doesFileExist,
132− getHomeDirectory)
133−import System.Environment (lookupEnv)
134−import System.FilePath ((</>))
135−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
136
322−@
137+-- | Attempt credentials discovery via the following steps:
323−{
138+--
324− \"token_type\": \"Bearer\",
139+-- * Read the default credentials from a file specified by
325− \"access_token\": \"eyJhbGci...\",
140+-- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists.
326− \"refresh_token\": \"1/B3gq9K...\",
141+--
327− \"expires_in\": 3600,
142+-- * Read the platform equivalent of @~\/.config\/gcloud\/application_default_credentials.json@ if it exists.
328− ...
143+-- The @~/.config@ component of the path can be overriden by the environment
329−}
144+-- variable @CLOUDSDK_CONFIG@ if it exists.
330−@
145+--
331−
146+-- * Retrieve the default service account application credentials if
332−The '_tokenAccess' field will be inserted verbatim into the
147+-- running on GCE. The environment variable @NO_GCE_CHECK@ can be used to
333−@Authorization: Bearer ...@ header for all HTTP requests.
148+-- skip this check if set to a truthy value such as @1@ or @true@.
334−-}
149+--
335−data OAuthToken = OAuthToken
150+-- The specified 'Scope's are used to authorize any @service_account@ that is
336− { _tokenAccess :: !AccessToken
151+-- found with the appropriate scopes, otherwise they are not used. See the
337− , _tokenRefresh :: !(Maybe RefreshToken)
152+-- top-level module of each individual @gogol-*@ library for a list of available
338− , _tokenExpiry :: !UTCTime
153+-- scopes, such as @Network.Google.Compute.computeScope@.
339− } deriving (Eq, Show)
154+-- discover :: (MonadIO m, MonadCatch m)
340−
155+-- => [OAuthScope]
341−instance FromJSON (UTCTime -> OAuthToken) where
156+-- -> Manager
342− parseJSON = withObject "bearer" $ \o -> do
157+-- -> m Credentials
343− t <- o .: "access_token"
158+-- discover ss m =
344− r <- o .:? "refresh_token"
159+-- catching _MissingFileError (fromFile ss) $ \f -> do
345− e <- o .: "expires_in" <&> fromInteger
160+-- p <- isGCE m
346− pure (OAuthToken t r . addUTCTime e)
161+-- unless p $
347−
162+-- throwingM _MissingFileError f
348−newtype OAuthCode = OAuthCode { codeToText :: Text }
163+-- pure $! FromMetadata "default"
349− deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
350
164
351-- | The supported credential mechanisms.
165-- | The supported credential mechanisms.
352data Credentials
166data Credentials
@@ -375,6 +189,31 @@ data Credentials
375 -- An 'AuthorizedUser' is typically created by the @gcloud init@ command
189 -- An 'AuthorizedUser' is typically created by the @gcloud init@ command
376 -- of the Google CloudSDK Tools.
190 -- of the Google CloudSDK Tools.
377
191
192+exchange :: (MonadIO m, MonadCatch m)
193+ => Credentials
194+ -> Logger
195+ -> Manager
196+ -> m OAuthToken
197+exchange c l m =
198+ case c of
199+ FromMetadata s -> metadataToken s l m
200+ FromAccount a ss -> serviceAccountToken a ss l m
201+ FromClient c' n -> exchangeCode c' n l m
202+ FromUser u -> authorizedUserToken u Nothing l m
203+
204+refresh :: (MonadIO m, MonadCatch m)
205+ => Credentials
206+ -> OAuthToken
207+ -> Logger
208+ -> Manager
209+ -> m OAuthToken
210+refresh c t l m =
211+ case c of
212+ FromMetadata s -> metadataToken s l m
213+ FromAccount a ss -> serviceAccountToken a ss l m
214+ FromClient c _ -> refreshToken c t l m
215+ FromUser u -> authorizedUserToken u (_tokenRefresh t) l m
216+
378-- | A credentials value in one of two possible states, pre-exchange and
217-- | A credentials value in one of two possible states, pre-exchange and
379-- containing a valid, but possibly expired access token.
218-- containing a valid, but possibly expired access token.
380data Auth
219data Auth
@@ -386,6 +225,14 @@ data Auth
386 -- ^ An 'OAuthToken' that can potentially be expired, with the original
225 -- ^ An 'OAuthToken' that can potentially be expired, with the original
387 -- credentials that can be used to perform a refresh.
226 -- credentials that can be used to perform a refresh.
388
227
228+validateToken :: MonadIO m => Auth -> m (Maybe OAuthToken)
229+validateToken Exchange {} = pure Nothing
230+validateToken (Refresh _ t) = do
231+ ts <- liftIO getCurrentTime
232+ if ts < _tokenExpiry t
233+ then pure (Just t)
234+ else pure Nothing
235+
389type Store = MVar Auth
236type Store = MVar Auth
390
237
391-- | Construct storage containing the credentials which have not yet been
238-- | Construct storage containing the credentials which have not yet been
@@ -393,85 +240,6 @@ type Store = MVar Auth
393emptyStore :: MonadIO m => Credentials -> m Store
240emptyStore :: MonadIO m => Credentials -> m Store
394emptyStore !c = liftIO . newMVar $ Exchange c
241emptyStore !c = liftIO . newMVar $ Exchange c
395
242
396−-- | Attempt credentials discovery via the following steps:
397−--
398−-- * Read the default credentials from a file specified by
399−-- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists.
400−--
401−-- * Read the platform equivalent of @~\/.config\/gcloud\/application_default_credentials.json@ if it exists.
402−-- The @~/.config@ component of the path can be overriden by the environment
403−-- variable @CLOUDSDK_CONFIG@ if it exists.
404−--
405−-- * Retrieve the default service account application credentials if
406−-- running on GCE. The environment variable @NO_GCE_CHECK@ can be used to
407−-- skip this check if set to a truthy value such as @1@ or @true@.
408−--
409−-- The specified 'Scope's are used to authorize any @service_account@ that is
410−-- found with the appropriate scopes, otherwise they are not used. See the
411−-- top-level module of each individual @gogol-*@ library for a list of available
412−-- scopes, such as @Network.Google.Compute.computeScope@.
413−discover :: (MonadIO m, MonadCatch m)
414− => [OAuthScope]
415− -> Manager
416− -> m Credentials
417−discover ss m =
418− catching _MissingFileError (fromFile ss) $ \f -> do
419− p <- isGCE m
420− unless p $
421− throwingM _MissingFileError f
422− pure $! FromMetadata "default"
423−
424−-- | Attempt to load either a @service_account@ or @authorized_user@ formatted
425−-- file to obtain the credentials neccessary to perform a token refresh.
426−--
427−-- The specified 'Scope's are used to authorize any @service_account@ that is
428−-- found with the appropriate scopes, otherwise they are not used. See the
429−-- top-level module of each individual @gogol-*@ library for a list of available
430−-- scopes, such as @Network.Google.Compute.computeScope@.
431−--
432−-- /See:/ 'cloudSDKConfigPath', 'defaultCredentialsPath'.
433−fromFile :: (MonadIO m, MonadCatch m) => [OAuthScope] -> m Credentials
434−fromFile ss = do
435− f <- defaultCredentialsPath
436− case f of
437− Just x -> fromFilePath ss x
438− Nothing -> do
439− x <- cloudSDKConfigPath
440− fromFilePath ss x
441−
442−-- | Attempt to load either a @service_account@ or @authorized_user@ formatted
443−-- file to obtain the credentials neccessary to perform a token refresh from
444−-- the specified file.
445−--
446−-- The specified 'Scope's are used to authorize any @service_account@ that is
447−-- found with the appropriate scopes, otherwise they are not used. See the
448−-- top-level module of each individual @gogol-*@ library for a list of available
449−-- scopes, such as @Network.Google.Compute.computeScope@.
450−fromFilePath :: (MonadIO m, MonadCatch m)
451− => [OAuthScope]
452− -> FilePath
453− -> m Credentials
454−fromFilePath ss f = do
455− p <- liftIO (doesFileExist f)
456− unless p $
457− throwM (MissingFileError f)
458− bs <- liftIO (LBS.readFile f)
459− either (throwM . InvalidFileError f . Text.pack) pure
460− (fromJSONCredentials ss bs)
461−
462−fromJSONCredentials :: [OAuthScope]
463− -> LBS.ByteString
464− -> Either String Credentials
465−fromJSONCredentials ss bs = do
466− v <- eitherDecode' bs
467− let x = (`FromAccount` ss) <$> parseEither parseJSON v
468− y = FromUser <$> parseEither parseJSON v
469− case (x, y) of
470− (Left xe, Left ye) -> Left $
471− "Failed parsing service_account: " ++ xe ++
472− ", Failed parsing authorized_user: " ++ ye
473− _ -> x <|> y
474−
475authorize :: (MonadIO m, MonadCatch m)
243authorize :: (MonadIO m, MonadCatch m)
476 => Client.Request
244 => Client.Request
477 -> Store
245 -> Store
@@ -483,7 +251,7 @@ authorize rq s l m = bearer <$> getToken s l m
483 bearer t = rq
251 bearer t = rq
484 { Client.requestHeaders =
252 { Client.requestHeaders =
485 ( hAuthorization
253 ( hAuthorization
486− , "Bearer " <> Text.encodeUtf8 (accessToText (_tokenAccess t))
254+ , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
487 ) : Client.requestHeaders rq
255 ) : Client.requestHeaders rq
488 }
256 }
489
257
@@ -509,240 +277,3 @@ getToken s l m = do
509 Refresh c t -> do
277 Refresh c t -> do
510 t' <- refresh c t l m
278 t' <- refresh c t l m
511 pure (Refresh c t', t')
279 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−
521−exchange :: (MonadIO m, MonadCatch m)
522− => Credentials
523− -> Logger
524− -> Manager
525− -> m OAuthToken
526−exchange c l m =
527− case c of
528− FromMetadata s -> refreshMetadata s l m
529− FromAccount a ss -> refreshAssertion a ss l m
530− FromClient c' n -> exchangeCode c' n l m
531− FromUser AuthorizedUser{..} ->
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−
550−refresh :: (MonadIO m, MonadCatch m)
551− => Credentials
552− -> OAuthToken
553− -> Logger
554− -> Manager
555− -> m OAuthToken
556−refresh c OAuthToken{..} l m =
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
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
626− Nothing -> mempty
627− Just (bs', x)
628− | x == '=' -> bs'
629− | otherwise -> bs
630−
631− input n = header <> "." <> payload
632− where
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)
665− => Client.Request
666− -> Logger
667− -> Manager
668− -> m OAuthToken
669−refreshRequest rq l m = do
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
684− success s bs = do
685− f <- parseErr s bs
686− ts <- liftIO getCurrentTime
687− pure (f ts)
688−
689− failure s bs = do
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+184
@@ -0,0 +1,184 @@
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+-- -- | Attempt to load either a @service_account@ or @authorized_user@ formatted
113+-- -- file to obtain the credentials neccessary to perform a token refresh.
114+-- --
115+-- -- The specified 'Scope's are used to authorize any @service_account@ that is
116+-- -- found with the appropriate scopes, otherwise they are not used. See the
117+-- -- top-level module of each individual @gogol-*@ library for a list of available
118+-- -- scopes, such as @Network.Google.Compute.computeScope@.
119+-- --
120+-- -- /See:/ 'cloudSDKConfigPath', 'defaultCredentialsPath'.
121+-- fromFile :: (MonadIO m, MonadCatch m) => [OAuthScope] -> m Credentials
122+-- fromFile ss = do
123+-- f <- defaultCredentialsPath
124+-- case f of
125+-- Just x -> fromFilePath ss x
126+-- Nothing -> do
127+-- x <- cloudSDKConfigPath
128+-- fromFilePath ss x
129+
130+-- -- | Attempt to load either a @service_account@ or @authorized_user@ formatted
131+-- -- file to obtain the credentials neccessary to perform a token refresh from
132+-- -- the specified file.
133+-- --
134+-- -- The specified 'Scope's are used to authorize any @service_account@ that is
135+-- -- found with the appropriate scopes, otherwise they are not used. See the
136+-- -- top-level module of each individual @gogol-*@ library for a list of available
137+-- -- scopes, such as @Network.Google.Compute.computeScope@.
138+-- fromFilePath :: (MonadIO m, MonadCatch m)
139+-- => [OAuthScope]
140+-- -> FilePath
141+-- -> m Credentials
142+-- fromFilePath ss f = do
143+-- p <- liftIO (doesFileExist f)
144+-- unless p $
145+-- throwM (MissingFileError f)
146+-- bs <- liftIO (LBS.readFile f)
147+-- either (throwM . InvalidFileError f . Text.pack) pure
148+-- (fromJSONCredentials ss bs)
149+
150+-- fromJSONCredentials :: [OAuthScope]
151+-- -> LBS.ByteString
152+-- -> Either String Credentials
153+-- fromJSONCredentials ss bs = do
154+-- v <- eitherDecode' bs
155+-- let x = (`FromAccount` ss) <$> parseEither parseJSON v
156+-- y = FromUser <$> parseEither parseJSON v
157+-- case (x, y) of
158+-- (Left xe, Left ye) -> Left $
159+-- "Failed parsing service_account: " ++ xe ++
160+-- ", Failed parsing authorized_user: " ++ ye
161+-- _ -> x <|> y
162+
163+-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
164+-- default application credentials filepath.
165+defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
166+defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile)
167+
168+-- | Return the filepath to the Cloud SDK well known file location such as
169+-- @~\/.config\/gcloud\/application_default_credentials.json@.
170+cloudSDKConfigPath :: MonadIO m => m FilePath
171+cloudSDKConfigPath = do
172+ m <- liftIO (lookupEnv cloudSDKConfigDir)
173+ case m of
174+ Just d -> pure $! d </> "application_default_credentials.json"
175+ Nothing -> do
176+ d <- getConfigDirectory
177+ pure $! d </> "gcloud/application_default_credentials.json"
178+
179+getConfigDirectory :: MonadIO m => m FilePath
180+getConfigDirectory = do
181+ h <- liftIO getHomeDirectory
182+ if os == "windows"
183+ then pure h
184+ 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 <- encodeJWTBearer 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+encodeJWTBearer :: (MonadIO m, MonadThrow m)
130+ => ServiceAccount
131+ -> [OAuthScope]
132+ -> m ByteString
133+encodeJWTBearer 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/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