@@ -18,48 +18,49 @@
1818--
1919-- Explicitly specify your Google credentials, or retrieve them
2020-- from the underlying OS.
21−module Network.Google.Auth
22− (
23− -- * Authentication
24− -- ** Retrieving Authentication
25− getAuth
26− , Credentials (..)
27− , Auth
28−
29− -- ** Default Constants
30− -- *** GCE
31− , checkGCEVar
32−
33− -- *** Cloud SDK
34− , cloudSDKCredentialsDirVar
35− , cloudSDKCredentialsDir
36− , cloudSDKCredentialsFile
37− , cloudSDKCredentialsPath
38−
39− -- *** Application Default Credentials
40− , defaultCredentialsFileVar
41− , defaultCredentialsPath
42−
43− -- ** Credentials
44− , fromToken
45− , fromFile
46− , fromFilePath
47− , fromAccount
48−
49− -- ** Authentication Tokens
50− , refreshToken
51−
52− -- ** Handling Errors
53− , AsAuthError (..)
54− , AuthError (..)
55−
56− -- ** Re-exported Types
57− , OAuthScope (..)
58− , OAuthToken (..)
59− , ServiceId (..)
60− , ClientId (..)
61− ) where
62−
21+module Network.Google.Auth where
22+ -- (
23+ -- -- * Authentication
24+ -- -- ** Retrieving Authentication
25+ -- getAuth
26+ -- , Credentials (..)
27+ -- , Auth
28+
29+ -- -- ** Default Constants
30+ -- -- *** GCE
31+ -- , checkGCEVar
32+
33+ -- -- *** Cloud SDK
34+ -- , cloudSDKCredentialsDirVar
35+ -- , cloudSDKCredentialsDir
36+ -- , cloudSDKCredentialsFile
37+ -- , cloudSDKCredentialsPath
38+
39+ -- -- *** Application Default Credentials
40+ -- , defaultCredentialsFileVar
41+ -- , defaultCredentialsPath
42+
43+ -- -- ** Credentials
44+ -- , fromToken
45+ -- , fromFile
46+ -- , fromFilePath
47+ -- , fromAccount
48+
49+ -- -- ** Authentication Tokens
50+ -- , refreshToken
51+
52+ -- -- ** Handling Errors
53+ -- , AsAuthError (..)
54+ -- , AuthError (..)
55+
56+ -- -- ** Re-exported Types
57+ -- , OAuthScope (..)
58+ -- , OAuthToken (..)
59+ -- , ServiceId (..)
60+ -- , ClientId (..)
61+ -- ) where
62+
63+import Data.ByteArray.Encoding
6364import Control.Concurrent
6465import Control.Exception.Lens
6566import Control.Lens
@@ -67,7 +68,6 @@ import Control.Monad
6768import Control.Monad.Catch
6869import Control.Monad.IO.Class
6970import Data.Aeson
70−import Data.ByteString (ByteString)
7171import qualified Data.ByteString.Lazy as LBS
7272import Data.Default.Class (def)
7373import qualified Data.Text as Text
@@ -76,7 +76,7 @@ import Data.Time
7676import Data.Typeable
7777import Network.Google.Compute.Metadata
7878import Network.Google.Prelude
79−import Network.HTTP.Conduit
79+import Network.HTTP.Conduit hiding (Request)
8080import qualified Network.HTTP.Conduit as Client
8181import Network.HTTP.Types
8282import System.Directory (doesFileExist,
@@ -85,23 +85,17 @@ import System.Environment (lookupEnv)
8585import System.FilePath ((</>))
8686import System.Info (os)
8787
88−accountsHost :: ByteString
89−accountsHost = "accounts.google.com"
88+maxTokenLifetimeSeconds :: Int
89+maxTokenLifetimeSeconds = 3600 -- 1 hour in seconds.
9090
9191-- | The environment variable name which can replace ~/.config if set.
92−cloudSDKCredentialsDirVar :: String
93−cloudSDKCredentialsDirVar = "CLOUDSDK_CONFIG"
94−
95−cloudSDKCredentialsDir :: FilePath
96−cloudSDKCredentialsDir = "gcloud"
97−
98−cloudSDKCredentialsFile :: FilePath
99−cloudSDKCredentialsFile = "application_default_credentials.json"
92+cloudSDKCredentialsDir :: String
93+cloudSDKCredentialsDir = "CLOUDSDK_CONFIG"
10094
10195-- | The environment variable pointing the file with local
10296-- Application Default Credentials.
103−defaultCredentialsFileVar :: String
104−defaultCredentialsFileVar = "GOOGLE_APPLICATION_CREDENTIALS"
97+defaultCredentialsFile :: String
98+defaultCredentialsFile = "GOOGLE_APPLICATION_CREDENTIALS"
10599
106100-- | An error thrown when attempting to read AuthN/AuthZ information.
107101data AuthError
@@ -194,119 +188,62 @@ data Credentials
194188-- cannot be read, and credentials files are invalid or cannot be found.
195189getAuth :: (MonadIO m, MonadCatch m) => Manager -> Credentials -> m Auth
196190getAuth m = \case
197− FromToken t -> pure (fromToken t)
198− FromFile f -> fromFilePath m f
199− FromAccount s -> fromAccount m s
200− Discover ->
191+ FromToken t -> pure (AuthToken t)
192+ FromFile f -> fromFilePath m f
193+ Discover ->
201194 catching _MissingFileError (fromFile m) $ \f -> do
202195 p <- isGCE m
203196 unless p $
204197 throwingM _MissingFileError f
205− fromAccount m "default"
198+ fromMetadata m "default"
206199
207−-- | An explicit access token.
208−fromToken :: OAuthToken -> Auth
209−fromToken = Tok
200+fromMetadata :: (MonadIO m, MonadCatch m) => Manager -> ServiceId -> m Auth
201+fromMetadata m = refresh m >=> fmap AuthMeta . liftIO . newMVar
210202
211−-- | Try the two offical locations for the application credentials:
212−--
213−-- * Read the default credentials from a file specified by
214−-- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists.
215−--
216−-- * Read the platform equivalent of @~/.config/gcloud/application_default_credentials.json@ if it exists.
217−-- The @~/.config@ component of the path can be overriden by the environment
218−-- variable @CLOUDSDK_CONFIG@ if it exists.
219−--
220−-- The read credentials will then be automatically refreshed to obtain a valid
221−-- access token, eagerly, to ensure errors propagate promptly.
222−fromFile :: MonadIO m => Manager -> m Auth
203+fromFile :: (MonadIO m, MonadCatch m) => Manager -> m Auth
223204fromFile m = do
224− mf <- defaultCredentialsPath
225− case mf of
226− Just f -> fromFilePath m f
227− Nothing -> cloudSDKCredentialsPath >>= fromFilePath m
228−
229−-- | Read a specific file for the application credentials.
230−--
231−-- The read credentials will then be automatically refreshed to obtain a valid
232−-- access token, eagerly, to ensure errors propagate promptly.
233−fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth
234−fromFilePath m f = liftIO $ do
235− p <- doesFileExist f
205+ f <- defaultCredentialsPath
206+ case f of
207+ Just x -> fromFilePath m x
208+ Nothing -> cloudSDKConfigPath >>= fromFilePath m
209+
210+fromFilePath :: (MonadIO m, MonadCatch m) => Manager -> FilePath -> m Auth
211+fromFilePath m f = do
212+ p <- liftIO (doesFileExist f)
236213 unless p $
237214 throwM (MissingFileError f)
238− !u <- LBS.readFile f >>=
215+ e <- liftIO (LBS.readFile f) >>=
239216 either (throwM . InvalidFileError f) pure . parseLBS
240− !r <- refresh m u
241− Ref m <$> newMVar (r :: Refresh User)
242−
243−-- | Retrieve the credentials from the @/computeMetadata/v1/instance/service-accounts/@
244−-- endpoint using the specific service identifier.
245−fromAccount :: MonadIO m => Manager -> ServiceId -> m Auth
246−fromAccount m s = liftIO $ do
247− !r <- refresh m s
248− Ref m <$> newMVar (r :: Refresh ServiceId)
249−
250−data Auth where
251− Tok :: OAuthToken -> Auth
252− Ref :: RefreshToken a => Manager -> MVar (Refresh a) -> Auth
253−
254−-- | Perform a safe refresh of the access token by performing a non-blocking
255−-- read. Ensures there is only a single producer for the underlying authentication
256−-- refresh, causing other readers to block during the refresh process.
257−refreshToken :: MonadIO m => Auth -> m OAuthToken
258−refreshToken (Tok t) = pure t
259−refreshToken (Ref m r) = liftIO $ do
260− x <- readMVar r
261− xv <- isValid x
262− if xv
263− then pure (_rToken x)
264− else modifyMVar r $ \y -> do
265− yv <- isValid y
266− if yv
267− then pure (y, _rToken x)
268− else do
269− z <- refresh m (_rTarget y)
270− pure (z, _rToken z)
271−
272−-- | Check if the refresh context is still valid, that is, has not expired.
273−isValid :: Refresh a -> IO Bool
274−isValid r = (< _rExpiry r) <$> getCurrentTime
275−
276−-- | Return the filepath to the Cloud SDK well known file location such as
277−-- @~\/.config\/gcloud\/application_default_credentials.json@.
278−cloudSDKCredentialsPath :: MonadIO m => m FilePath
279−cloudSDKCredentialsPath = liftIO $ do
280− v <- lookupEnv cloudSDKCredentialsDirVar
281− h <- getHomeDirectory
282− let d = case v of
283− Nothing | os == "windows" -> h
284− Nothing -> h </> ".config"
285− Just x -> x
286− pure $! d
287− </> cloudSDKCredentialsDir
288− </> cloudSDKCredentialsFile
217+ case e of
218+ Left a -> pure (AuthSign a)
219+ Right u -> refresh m u >>= fmap AuthUser . liftIO . newMVar
289220
290221-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
291222-- default application credentials filepath.
292223defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
293−defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFileVar)
294−
295−data User = User
296− { _uId :: !ClientId
297− , _uSecret :: !Text
298− , _uRefresh :: !Text
299− }
224+defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile)
300225
301−instance FromJSON User where
302− parseJSON = withObject "authorized_user" $ \o -> User
303− <$> o .: "client_id"
304− <*> o .: "client_secret"
305− <*> o .: "refresh_token"
226+-- | Return the filepath to the Cloud SDK well known file location such as
227+-- @~\/.config\/gcloud\/application_default_credentials.json@.
228+cloudSDKConfigPath :: MonadIO m => m FilePath
229+cloudSDKConfigPath = do
230+ m <- liftIO (lookupEnv cloudSDKCredentialsDir)
231+ case m of
232+ Just d -> pure $! d </> "application_default_credentials.json"
233+ Nothing -> do
234+ d <- getConfigDirectory
235+ pure $! d </> "gcloud/application_default_credentials.json"
236+
237+getConfigDirectory :: MonadIO m => m FilePath
238+getConfigDirectory = do
239+ h <- liftIO getHomeDirectory
240+ if os == "windows"
241+ then pure h
242+ else pure $! h </> ".config"
306243
307244data RefreshError = RefreshError
308− { _eError :: !Text
309− , _eDescription :: !(Maybe Text)
245+ { _error :: !Text
246+ , _description :: !(Maybe Text)
310247 }
311248
312249instance FromJSON RefreshError where
@@ -314,97 +251,222 @@ instance FromJSON RefreshError where
314251 <$> o .: "error"
315252 <*> o .:? "error_description"
316253
317−data Refresh a = Refresh
318− { _rToken :: !OAuthToken
319− , _rExpiry :: !UTCTime
320− , _rTarget :: !a
254+data Expires a = Expires
255+ { _expiry :: !UTCTime
256+ , _token :: !OAuthToken
257+ , _details :: !a
258+ }
259+
260+isValid :: MonadIO m => Expires a -> m Bool
261+isValid r = (< _expiry r) <$> liftIO getCurrentTime
262+
263+data Auth
264+ = AuthToken !OAuthToken
265+ | AuthSign !(MVar (Expires ServiceAccount))
266+ | AuthMeta !(MVar (Expires ServiceId))
267+ | AuthUser !(MVar (Expires AuthorisedUser))
268+
269+authorise :: (MonadIO m, MonadCatch m)
270+ => Manager
271+ -> Request
272+ -> Auth
273+ -> m Request
274+authorise m rq = \case
275+ AuthToken t -> pure $! authoriseBearer rq t
276+ AuthSign r -> authoriseToken m r rq
277+ AuthMeta r -> authoriseToken m r rq
278+ AuthUser r -> authoriseToken m r rq
279+
280+authoriseBearer :: Request -> OAuthToken -> Request
281+authoriseBearer rq =
282+ appendHeader rq hAuthorization . Just . mappend "Bearer " . tokenToText
283+
284+authoriseToken :: (MonadIO m, MonadCatch m, Refresh a)
285+ => Manager
286+ -> MVar (Expires a)
287+ -> Request
288+ -> m Request
289+authoriseToken m r rq = authoriseBearer rq <$> refreshToken m r
290+
291+refreshToken :: (MonadIO m, MonadCatch m, Refresh a)
292+ => Manager
293+ -> MVar (Expires a)
294+ -> m OAuthToken
295+refreshToken m r = do
296+ x <- liftIO (readMVar r)
297+ xv <- isValid x
298+ if xv
299+ then pure (_token x)
300+ else liftIO . modifyMVar r $ \y -> do
301+ yv <- isValid y
302+ if yv
303+ then pure (y, _token y)
304+ else do
305+ z <- refresh m (_details y)
306+ pure (z, _token z)
307+
308+-- {
309+-- "access_token": "sadsdasd",
310+-- "expires_in": 3600,
311+-- "id_token": "eyJhbGciOiJSd",
312+-- "refresh_token": "1/B3gq9K",
313+-- "token_type": "Bearer"
314+-- }
315+
316+data Bearer = Bearer
317+ { _bearerAccess :: !OAuthToken
318+ , _bearerRefresh :: !(Maybe Text)
319+ , _bearerExpiry :: !UTCTime
321320 }
322321
323−instance FromJSON (UTCTime -> (Maybe Text -> a) -> Refresh a) where
324− parseJSON = withObject "refresh_token" $ \o -> do
322+instance FromJSON (UTCTime -> Bearer) where
323+ parseJSON = withObject "bearer" $ \o -> do
325324 t <- o .: "access_token"
326− e <- o .: "expires_in" <&> fromInteger
327325 r <- o .:? "refresh_token"
328− pure $ \ts f ->
329− Refresh t (addUTCTime e ts) (f r)
330−
331−class RefreshToken a where
332− refresh :: (MonadIO m, MonadCatch m) => Manager -> a -> m (Refresh a)
333−
334−instance RefreshToken User where
335− refresh m u@User {..} = perform m rq success failure
336− where
337− success s bs = do
338− f <- parseErr s bs
339− ts <- liftIO getCurrentTime
340− pure $! f ts $ \r ->
341− u { _uRefresh = fromMaybe _uRefresh r
342− }
343−
344− failure s bs = do
345− RefreshError {..} <- parseErr s bs
346− refreshErr s _eError _eDescription
347−
348− parseErr s bs =
349− case parseLBS bs of
350− Left e -> refreshErr s e Nothing
351− Right !x -> pure x
352−
353− refreshErr s e = throwM . TokenRefreshError s e
354−
355− rq = def
356− { Client.host = accountsHost
357− , Client.port = 443
358− , Client.secure = True
359− , Client.checkStatus = \_ _ _ -> Nothing
360− , Client.method = "POST"
361− , Client.path = "/o/oauth2/token"
362− , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]
363− , Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
326+ e <- o .: "expires_in" <&> fromInteger
327+ pure (Bearer t r . addUTCTime e)
328+
329+-- {
330+-- "private_key_id": "30edd1243ad77e5efdf2ce95223157bad5b33924",
331+-- "private_key": "-----BEGIN PRIVATE KEY-----\nMIIE...\n",
332+-- "client_email": "9910395191@er.gserviceaccount.com",
333+-- "client_id": "0351911-2310eusercontent.com",
334+-- "type": "service_account"
335+-- }
336+
337+data ServiceAccount = ServiceAccount
338+ { _serviceId :: !ClientId
339+ , _serviceEmail :: !Text
340+ , _serviceKeyId :: !Text
341+ , _serviceKey :: !Text
342+ }
343+
344+instance FromJSON ServiceAccount where
345+ parseJSON = withObject "service_account" $ \o -> ServiceAccount
346+ <$> o .: "client_id"
347+ <*> o .: "client_email"
348+ <*> o .: "private_key_id"
349+ <*> o .: "private_key"
350+
351+-- {
352+-- "client_id": "32555940559.apps.googleusercontent.com",
353+-- "client_secret": "ZmssLNjJy2998hD4CTg2ejr2",
354+-- "refresh_token": "1/B3gq9KM1xzIVtqffS1n5w-rSJLPVVPoRyJO7DljtvBY",
355+-- "type": "authorized_user"
356+-- }
357+
358+data AuthorisedUser = AuthorisedUser
359+ { _userId :: !ClientId
360+ , _userSecret :: !Text
361+ , _userRefresh :: !Text
362+ }
363+
364+instance FromJSON AuthorisedUser where
365+ parseJSON = withObject "authorized_user" $ \o -> AuthorisedUser
366+ <$> o .: "client_id"
367+ <*> o .: "client_secret"
368+ <*> o .: "refresh_token"
369+
370+class Refresh a where
371+ refresh :: (MonadIO m, MonadCatch m) => Manager -> a -> m (Expires a)
372+
373+instance Refresh ServiceAccount where
374+ refresh m s = refreshRequest m s $
375+ accountsRequest
376+ { Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
377+ "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"
378+ <> "&assertion=" <> generateAssertion s
379+ }
380+
381+ generateAssertion = do
382+ n <- truncate <$> getPOSIXTime
383+ readKeyFileFromMemory - do on parse.
384+
385+ where
386+ assertion = = input <> "." <> signature
387+
388+ signature = dropWhileEnd (base64 btes . rstrip(b'=')
389+
390+ bytes = rsa.pkcs1.sign(input, _serviceKey s, 'SHA256')
391+
392+ input n = header <> "." <> payload n
393+
394+ header = base64 . encode $ object
395+ [ "alg" .= ("RS256" :: Text)
396+ , "typ" .= ("JWT" :: Text)
397+ , "kid" .= _serviceKeyId s
398+ ]
399+
400+ payload n = base64 . encode $ object
401+ [ "aud" .= Client.host accountsRequest
402+ , "scope" .= ([] :: [Text])
403+ , "iat" .= n
404+ , "exp" .= n + maxTokenLifetimeSeconds
405+ , "iss" .= _serviceEmail s
406+ ]
407+
408+
409+instance Refresh AuthorisedUser where
410+ refresh m u@AuthorisedUser{..} = refreshRequest m u $
411+ accountsRequest
412+ { Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
364413 "grant_type=refresh_token"
365− <> "&client_id=" <> clientIdToText _uId
366− <> "&client_secret=" <> _uSecret
367− <> "&refresh_token=" <> _uRefresh
414+ <> "&client_id=" <> clientIdToText _userId
415+ <> "&client_secret=" <> _userSecret
416+ <> "&refresh_token=" <> _userRefresh
368417 }
369418
370−instance RefreshToken ServiceId where
371− refresh m sid = perform m rq success failure
372− where
373− success s bs = do
374− f <- parseErr s bs
375− ts <- liftIO getCurrentTime
376− pure $! f ts (const sid :: Maybe Text -> ServiceId)
377−
378− failure s = const $
379− refreshErr s "Failure refreshing token from http://metadata.google.internal"
380− Nothing
381−
382− parseErr s bs =
383− case parseLBS bs of
384− Left e -> refreshErr s e Nothing
385− Right !x -> pure x
386−
387− refreshErr s e = throwM . TokenRefreshError s e
388−
389− rq = metadataRequest
390− { Client.path = "instance/service-accounts/"
391− <> Text.encodeUtf8 (serviceIdToText sid)
392− <> "/token"
393− }
394−
395−perform :: (MonadIO m, MonadCatch m)
396− => Manager
397− -> Client.Request
398− -> (Status -> LBS.ByteString -> m a)
399− -> (Status -> LBS.ByteString -> m a)
400− -> m a
401−perform m rq success failure = do
419+instance Refresh ServiceId where
420+ refresh m sid = refreshRequest m sid $
421+ metadataRequest
422+ { Client.path = "instance/service-accounts/"
423+ <> Text.encodeUtf8 (serviceIdToText sid)
424+ <> "/token"
425+ }
426+
427+accountsRequest :: Client.Request
428+accountsRequest = def
429+ { Client.host = "accounts.google.com"
430+ , Client.port = 443
431+ , Client.secure = True
432+ , Client.checkStatus = \_ _ _ -> Nothing
433+ , Client.method = "POST"
434+ , Client.path = "/o/oauth2/token"
435+ , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]
436+ }
437+
438+refreshRequest :: (MonadIO m, MonadCatch m)
439+ => Manager
440+ -> a
441+ -> Client.Request
442+ -> m (Expires a)
443+refreshRequest m r rq = do
402444 rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)
403445 let bs = responseBody rs
404446 s = responseStatus rs
405447 if fromEnum s == 200
406448 then success s bs
407449 else failure s bs
450+ where
451+ success s bs = do
452+ f <- parseErr s bs
453+ ts <- liftIO getCurrentTime
454+ let Bearer {..} = f ts
455+ pure $! Expires _bearerExpiry _bearerAccess r
456+
457+ failure s = const $
458+ refreshErr s ("Failure refreshing token from " <> Text.pack (Client.host rq))
459+ Nothing
460+
461+ parseErr s bs =
462+ case parseLBS bs of
463+ Left e -> refreshErr s e Nothing
464+ Right !x -> pure x
465+
466+ refreshErr s e = throwM . TokenRefreshError s e
408467
409468parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
410469parseLBS = either (Left . Text.pack) Right . eitherDecode'
470+
471+-- base64 :: ToJSON a =>
472+base64 = convertToBase Base64URLUnpadded