@@ -60,20 +60,30 @@ module Network.Google.Auth where
6060 -- , ClientId (..)
6161 -- ) where
6262
63−import Data.ByteArray.Encoding
6463import Control.Concurrent
6564import Control.Exception.Lens
66−import Control.Lens
65+import Control.Lens hiding ((.=))
6766import Control.Monad
6867import Control.Monad.Catch
6968import Control.Monad.IO.Class
69+import Crypto.Hash.Algorithms (SHA256 (..))
70+import Crypto.PubKey.RSA.PKCS15 (signSafer)
71+import Crypto.PubKey.RSA.Types (PrivateKey)
7072import Data.Aeson
73+import Data.Aeson.Types
74+import Data.ByteArray
75+import Data.ByteArray.Encoding
76+import Data.ByteString (ByteString)
77+import qualified Data.ByteString.Char8 as BS8
7178import qualified Data.ByteString.Lazy as LBS
7279import Data.Default.Class (def)
7380import qualified Data.Text as Text
7481import qualified Data.Text.Encoding as Text
7582import Data.Time
83+import Data.Time.Clock.POSIX
7684import Data.Typeable
85+import Data.X509
86+import Data.X509.Memory
7787import Network.Google.Compute.Metadata
7888import Network.Google.Prelude
7989import Network.HTTP.Conduit hiding (Request)
@@ -188,9 +198,10 @@ data Credentials
188198-- cannot be read, and credentials files are invalid or cannot be found.
189199getAuth :: (MonadIO m, MonadCatch m) => Manager -> Credentials -> m Auth
190200getAuth m = \case
191− FromToken t -> pure (AuthToken t)
192− FromFile f -> fromFilePath m f
193− Discover ->
201+ FromToken t -> pure (AuthToken t)
202+ FromFile f -> fromFilePath m f
203+ FromAccount s -> fromMetadata m s
204+ Discover ->
194205 catching _MissingFileError (fromFile m) $ \f -> do
195206 p <- isGCE m
196207 unless p $
@@ -215,7 +226,7 @@ fromFilePath m f = do
215226 e <- liftIO (LBS.readFile f) >>=
216227 either (throwM . InvalidFileError f) pure . parseLBS
217228 case e of
218− Left a -> pure (AuthSign a)
229+ Left a -> refresh m a >>= fmap AuthSign . liftIO . newMVar
219230 Right u -> refresh m u >>= fmap AuthUser . liftIO . newMVar
220231
221232-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
@@ -268,24 +279,26 @@ data Auth
268279
269280authorise :: (MonadIO m, MonadCatch m)
270281 => Manager
271− -> Request
282+ -> Client.Request
272283 -> Auth
273− -> m Request
284+ -> m Client.Request
274285authorise m rq = \case
275286 AuthToken t -> pure $! authoriseBearer rq t
276287 AuthSign r -> authoriseToken m r rq
277288 AuthMeta r -> authoriseToken m r rq
278289 AuthUser r -> authoriseToken m r rq
279290
280−authoriseBearer :: Request -> OAuthToken -> Request
281−authoriseBearer rq =
282− appendHeader rq hAuthorization . Just . mappend "Bearer " . tokenToText
291+authoriseBearer :: Client.Request -> OAuthToken -> Client.Request
292+authoriseBearer rq t = rq
293+ { Client.requestHeaders = (hAuthorization, "Bearer " <> tokenToBS t)
294+ : Client.requestHeaders rq
295+ }
283296
284297authoriseToken :: (MonadIO m, MonadCatch m, Refresh a)
285298 => Manager
286299 -> MVar (Expires a)
287− -> Request
288− -> m Request
300+ -> Client.Request
301+ -> m Client.Request
289302authoriseToken m r rq = authoriseBearer rq <$> refreshToken m r
290303
291304refreshToken :: (MonadIO m, MonadCatch m, Refresh a)
@@ -338,15 +351,23 @@ data ServiceAccount = ServiceAccount
338351 { _serviceId :: !ClientId
339352 , _serviceEmail :: !Text
340353 , _serviceKeyId :: !Text
341− , _serviceKey :: !Text
354+ , _serviceKey :: !PrivateKey
342355 }
343356
344357instance 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"
358+ parseJSON = withObject "service_account" $ \o -> do
359+ bs <- Text.encodeUtf8 <$> o .: "private_key_id"
360+ ServiceAccount
361+ <$> o .: "client_id"
362+ <*> o .: "client_email"
363+ <*> o .: "private_key"
364+ <*> parseKey bs
365+ where
366+ parseKey bs =
367+ case listToMaybe (readKeyFileFromMemory bs) of
368+ Just (PrivKeyRSA k) -> pure k
369+ _ ->
370+ fail "Unable to parse key contents from 'private_key_id'"
350371
351372-- {
352373-- "client_id": "32555940559.apps.googleusercontent.com",
@@ -371,40 +392,57 @@ class Refresh a where
371392 refresh :: (MonadIO m, MonadCatch m) => Manager -> a -> m (Expires a)
372393
373394instance Refresh ServiceAccount where
374− refresh m s = refreshRequest m s $
375− accountsRequest
376− { Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
395+ refresh m s = do
396+ b <- jwtEncode s
397+ refreshRequest m s $ accountsRequest
398+ { Client.requestBody = RequestBodyBS $
377399 "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"
378− <> "&assertion=" <> generateAssertion s
400+ <> "&assertion="
401+ <> b
379402 }
380403
381− generateAssertion = do
382− n <- truncate <$> getPOSIXTime
383− readKeyFileFromMemory - do on parse.
384−
385− where
386− assertion = = input <> "." <> signature
404+ -- first_segment = _urlsafe_b64encode(_json_encode(header))
405+ -- second_segment = _urlsafe_b64encode(_json_encode(payload))
406+ -- assertion_input = first_segment + b'.' + second_segment
387407
388− signature = dropWhileEnd (base64 btes . rstrip(b'=')
408+ -- # Sign the assertion.
409+ -- rsa_bytes = rsa.pkcs1.sign(assertion_input, self._private_key,
410+ -- 'SHA-256')
411+ -- signature = base64.urlsafe_b64encode(rsa_bytes).rstrip(b'=')
389412
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− ]
413+ -- return assertion_input + b'.' + signature
407414
415+jwtEncode :: (MonadIO m, MonadThrow m) => ServiceAccount -> m ByteString
416+jwtEncode s = liftIO $ do
417+ i <- input . truncate <$> getPOSIXTime
418+ r <- signSafer (Just SHA256) (_serviceKey s) i
419+ either failure (\x -> pure (i <> "." <> signature (base64 x))) r
420+ where
421+ failure e = throwM $
422+ TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing
423+
424+ signature bs =
425+ case BS8.unsnoc bs of
426+ Nothing -> mempty
427+ Just (bs', x)
428+ | x == '=' -> bs'
429+ | otherwise -> bs
430+
431+ input n = header <> "." <> payload
432+ where
433+ header = base64Encode
434+ [ "alg" .= ("RS256" :: Text)
435+ , "typ" .= ("JWT" :: Text)
436+ , "kid" .= _serviceKeyId s
437+ ]
438+
439+ payload = base64Encode
440+ [ "aud" .= Text.decodeUtf8 (Client.host accountsRequest)
441+ , "scope" .= ([] :: [Text])
442+ , "iat" .= n
443+ , "exp" .= (n + maxTokenLifetimeSeconds)
444+ , "iss" .= _serviceEmail s
445+ ]
408446
409447instance Refresh AuthorisedUser where
410448 refresh m u@AuthorisedUser{..} = refreshRequest m u $
@@ -455,7 +493,7 @@ refreshRequest m r rq = do
455493 pure $! Expires _bearerExpiry _bearerAccess r
456494
457495 failure s = const $
458− refreshErr s ("Failure refreshing token from " <> Text.pack (Client.host rq))
496+ refreshErr s ("Failure refreshing token from " <> Text.decodeUtf8 (Client.host rq))
459497 Nothing
460498
461499 parseErr s bs =
@@ -468,5 +506,9 @@ refreshRequest m r rq = do
468506parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
469507parseLBS = either (Left . Text.pack) Right . eitherDecode'
470508
471−-- base64 :: ToJSON a =>
509+base64Encode :: [Pair] -> ByteString
510+base64Encode = base64 . LBS.toStrict . encode . object
511+
512+-- base64 :: ToJSON a =>
513+base64 :: ByteArray a => a -> ByteString
472514base64 = convertToBase Base64URLUnpadded