c0d3b59 · gogol · git.iko.soy

git.iko.soy/gogol

on develop help sign in

Adding serivce account refresh support

c0d3b59Brendan Hay11 years ago

core/src/Network/Google/Types.hs+7−4

compare with develop

unifiedsplit

@@ -68,10 +68,10 @@ instance ToText AltMedia where

68newtype AuthKey = AuthKey Text

69 deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)

71−newtype OAuthToken = OAuthToken Text

71+newtype OAuthToken = OAuthToken { tokenToText :: Text }

72 deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)

74−newtype OAuthScope = OAuthScope Text

74+newtype OAuthScope = OAuthScope { scopeToText :: Text }

75 deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)

77newtype Bearer a = Bearer a

@@ -98,8 +98,11 @@ _Default = iso f Just

98type Body = Source IO ByteString

99type Stream = ResumableSource (ResourceT IO) ByteString

100

101+newtype ClientId = ClientId { clientIdToText :: Text }

102+ deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)

103+

101−newtype ServiceId = ServiceId Text

104+newtype ServiceId = ServiceId { serviceIdToText :: Text }

102− deriving (Eq, Show, Typeable)

105+ deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON)

103

106

104data Error

107data Error

105 = TransportError HttpException

108 = TransportError HttpException

gogol/src/Network/Google/Auth.hs+173−182

@@ -1,4 +1,8 @@

1+{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE OverloadedStrings #-}

8{-# LANGUAGE OverloadedStrings #-}

@@ -20,6 +24,7 @@ import Control.Concurrent

20import Control.Concurrent.MVar

24import Control.Concurrent.MVar

21import Control.Exception

25import Control.Exception

22import Control.Exception.Lens

26import Control.Exception.Lens

27+import Control.Lens

23import Control.Monad

28import Control.Monad

24import Control.Monad.Catch

29import Control.Monad.Catch

25import Control.Monad.IO.Class

30import Control.Monad.IO.Class

@@ -38,24 +43,79 @@ import Network.HTTP.Conduit

38-- import qualified Network.HTTP.Client.Conduit as C

43-- import qualified Network.HTTP.Client.Conduit as C

39import qualified Network.HTTP.Conduit as Client

44import qualified Network.HTTP.Conduit as Client

40import Network.HTTP.Types

45import Network.HTTP.Types

41−import System.Directory (getHomeDirectory)

46+import System.Directory (doesFileExist, getHomeDirectory)

42import System.Environment (lookupEnv)

47import System.Environment (lookupEnv)

43import System.FilePath ((</>))

48import System.FilePath ((</>))

44import System.Info (os)

49import System.Info (os)

46−-- withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a

51+data Credentials

47−-- withAuth (Ref _ r) f = liftIO (readIORef r) >>= f

52+ = FromToken !OAuthToken

48−-- withAuth (Auth e) f = f e

53+ | FromFile !FilePath

54+ | Discover

55+ deriving (Eq, Show)

56+

57+getAuth :: MonadIO m => Manager -> Credentials -> m Auth

58+getAuth m = \case

59+ FromToken t -> pure (fromToken t)

60+ FromFile f -> fromFilePath m f

61+ Discover -> undefined

62+ -- catching _MissingFileError fromFile $ \f -> do

63+ -- p <- detectGCE m

64+ -- unless p $

65+ -- throwingM _MissingFileError f

66+ -- fromMetadata m

67+

68+fromToken :: OAuthToken -> Auth

69+fromToken = Tok

50−-- -- | Retrieve authentication information via the specified 'Credentials' mechanism.

71+fromFile :: MonadIO m => Manager -> m Auth

51−-- getAuth :: Monad m => Credentials -> m Auth

72+fromFile m = defaultCredentialsPath >>= fromFilePath m

52−-- getAuth = \case

53−-- FromKey k -> pure $! Auth (AuthEnv (Left k) Nothing)

54−-- FromToken t -> pure $! Auth (AuthEnv (Right t) Nothing)

74+fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth

75+fromFilePath m f = liftIO $ do

76+ p <- doesFileExist f

77+ unless p $

78+ throwM (MissingFileError f)

79+ !u <- LBS.readFile f >>=

80+ either (throwM . InvalidFileError f) pure . parseLBS

81+ !r <- refresh m u

82+ Ref m <$> newMVar (r :: Refresh User)

57−-- -- | Expiry is stored in RFC3339 UTC format

84+fromMetadata :: MonadIO m => Manager -> ServiceId -> m Auth

58−-- EXPIRY_FORMAT = "%Y-%m-%dT%H:%M:%SZ"

85+fromMetadata m s = liftIO $ do

86+ !r <- refresh m s

87+ Ref m <$> newMVar (r :: Refresh ServiceId)

88+

89+data Auth where

90+ Tok :: OAuthToken -> Auth

91+ Ref :: RefreshToken a => Manager -> MVar (Refresh a) -> Auth

92+

93+withToken :: MonadIO m => Auth -> (OAuthToken -> m a) -> m a

94+withToken x f = liftIO (refreshToken x) >>= f

95+

96+refreshToken :: Auth -> IO OAuthToken

97+refreshToken (Tok t) = pure t

98+refreshToken (Ref m r) = do

99+ x <- readMVar r

100+ xv <- isValid x

101+ if xv

102+ then pure (_rToken x)

103+ else modifyMVar r $ \y -> do

104+ yv <- isValid y

105+ if yv

106+ then pure (y, _rToken x)

107+ else do

108+ z <- refresh m (_rTarget y)

109+ pure (z, _rToken z)

110+

111+isValid :: Refresh a -> IO Bool

112+isValid r = (< _rExpiry r) <$> getCurrentTime

113+

114+-- GOOGLE_AUTH_URI = 'https://accounts.google.com/o/oauth2/auth'

115+-- GOOGLE_DEVICE_URI = 'https://accounts.google.com/o/oauth2/device/code'

116+-- GOOGLE_REVOKE_URI = 'https://accounts.google.com/o/oauth2/revoke'

117+-- GOOGLE_TOKEN_URI = 'https://accounts.google.com/o/oauth2/token'

118+-- GOOGLE_TOKEN_INFO_URI = 'https://www.googleapis.com/oauth2/v2/tokeninfo'

119

60-- -- | Which certs to use to validate id_tokens received.

120-- -- | Which certs to use to validate id_tokens received.

61-- ID_TOKEN_VERIFICATION_CERTS = "https://www.googleapis.com/oauth2/v1/certs"

121-- ID_TOKEN_VERIFICATION_CERTS = "https://www.googleapis.com/oauth2/v1/certs"

@@ -129,8 +189,8 @@ detectGCE m = pure False

129-- finally:

189-- finally:

130-- connection.close()

190-- connection.close()

131

191

132−isGAE :: MonadIO m => m Bool

192+-- isGAE :: MonadIO m => m Bool

133−isGAE = pure False

193+-- isGAE = pure False

134 -- if SETTINGS.env_name is not None:

194 -- if SETTINGS.env_name is not None:

135 -- return SETTINGS.env_name in ('GAE_PRODUCTION', 'GAE_LOCAL')

195 -- return SETTINGS.env_name in ('GAE_PRODUCTION', 'GAE_LOCAL')

136

196

@@ -148,8 +208,8 @@ isGAE = pure False

148

208

149 -- return False

209 -- return False

150

210

151−isGCE :: MonadIO m => m Bool

211+-- isGCE :: MonadIO m => m Bool

152−isGCE = pure False

212+-- isGCE = pure False

153-- def _in_gce_environment():

213-- def _in_gce_environment():

154-- """Detect if the code is running in the Compute Engine environment.

214-- """Detect if the code is running in the Compute Engine environment.

155-- Returns:

215-- Returns:

@@ -163,14 +223,11 @@ isGCE = pure False

163-- return True

223-- return True

164-- return False

224-- return False

165

225

166−newtype ClientId = ClientId { clientId :: Text }

167− deriving (Eq, Show, FromJSON, ToJSON)

168−

169data AuthError

226data AuthError

170 = RetrievalError HttpException

227 = RetrievalError HttpException

171 | MissingFileError FilePath

228 | MissingFileError FilePath

172 | InvalidFileError FilePath Text

229 | InvalidFileError FilePath Text

173− | TokenRefreshError Status ClientId Text (Maybe Text)

230+ | TokenRefreshError Status Text (Maybe Text)

174 deriving (Show, Typeable)

231 deriving (Show, Typeable)

175

232

176instance Exception AuthError

233instance Exception AuthError

@@ -193,181 +250,115 @@ defaultCredentialsPath = liftIO $ do

193 Just x -> h </> x

250 Just x -> h </> x

194 pure $! d </> cloudSDKConfigFile

251 pure $! d </> cloudSDKConfigFile

195

252

196−data AuthorizedUser = AuthorizedUser

253+data User = User

197− { _auClientId :: !ClientId

254+ { _uId :: !ClientId

198− , _auClientSecret :: !Text

255+ , _uSecret :: !Text

199− , _auRefreshToken :: !Text

256+ , _uRefresh :: !Text

200 }

257 }

201

258

202−instance FromJSON AuthorizedUser where

259+instance FromJSON User where

203− parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser

260+ parseJSON = withObject "authorized_user" $ \o -> User

204 <$> o .: "client_id"

261 <$> o .: "client_id"

205 <*> o .: "client_secret"

262 <*> o .: "client_secret"

206 <*> o .: "refresh_token"

263 <*> o .: "refresh_token"

207

264

208−data AuthorizedRefresh = AuthorizedRefresh

265+data RefreshError = RefreshError

209− { _arAccessToken :: !OAuthToken

266+ { _eError :: !Text

210− , _arRefreshToken :: !(Maybe Text)

211− , _arExpiresIn :: !NominalDiffTime

212− }

213−

214−instance FromJSON AuthorizedRefresh where

215− parseJSON = withObject "authorized_refresh" $ \o -> AuthorizedRefresh

216− <$> o .: "access_token"

217− <*> o .:? "refresh_token"

218− <*> (fromInteger <$> o .: "expires_in")

219−

220−data AuthorizedError = AuthorizedError

221− { _aeError :: !Text

222− , _aeDescription :: !(Maybe Text)

267+ , _eDescription :: !(Maybe Text)

223 }

268 }

224

269

225−instance FromJSON AuthorizedError where

270+instance FromJSON RefreshError where

226− parseJSON = withObject "authorized_error" $ \o -> AuthorizedError

271+ parseJSON = withObject "refresh_error" $ \o -> RefreshError

227 <$> o .: "error"

272 <$> o .: "error"

228 <*> o .:? "error_description"

273 <*> o .:? "error_description"

229

274

230−refreshUser :: Manager -> AuthorizedUser -> IO (Refresh AuthorizedUser)

231−refreshUser m u@AuthorizedUser {..} = do

232− rs <- httpLbs rq m

233− let bs = responseBody rs

234− s = responseStatus rs

235− if fromEnum s == 200 then success s bs else failure s bs

236− where

237− failure s bs = do

238− AuthorizedError {..} <- parseErr s bs

239− refreshErr s _aeError _aeDescription

240−

241− success s bs = do

242− AuthorizedRefresh {..} <- parseErr s bs

243− ts <- getCurrentTime

244− pure $! Refresh (addUTCTime _arExpiresIn ts) _arAccessToken $

245− u { _auRefreshToken = fromMaybe _auRefreshToken _arRefreshToken }

246−

247− parseErr s bs =

248− case parseLBS bs of

249− Left e -> refreshErr s e Nothing

250− Right x -> pure x

251−

252− refreshErr s e = throwM . TokenRefreshError s _auClientId e

253−

254− rq = def

255− { Client.host = "accounts.google.com"

256− , Client.port = 443

257− , Client.secure = True

258− , Client.checkStatus = \_ _ _ -> Nothing

259− , Client.method = "POST"

260− , Client.path = "/o/oauth2/token"

261− , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]

262− , Client.requestBody = RequestBodyBS . Text.encodeUtf8 $

263− "grant_type=refresh_token"

264− <> "&client_id=" <> clientId _auClientId

265− <> "&client_secret=" <> _auClientSecret

266− <> "&refresh_token=" <> _auRefreshToken

267− }

268−

269−-- data ServiceAccount = ServiceAccount

270−-- { _saClientId :: !Text

271−-- , _saClientEmail :: !Text

272−-- , _saPrivateKeyId :: !Text

273−-- , _saPrivateKey :: !Text

274−-- }

275−

276−-- instance FromJSON ServiceAccount where

277−-- parseJSON = withObject "service_account" $ \o -> ServiceAccount

278−-- <$> o .: "client_id"

279−-- <*> o .: "client_email"

280−-- <*> o .: "private_key_id"

281−-- <*> o .: "private_key"

282−

283−data DefaultCredentials

284− = User !AuthorizedUser

285−-- | Account !ServiceAccount

286−

287−instance FromJSON DefaultCredentials where

288− parseJSON = withObject "default_credentials" $ \o -> do

289− t <- o .: "type"

290− case t of

291− "authorized_user" -> User <$> parseJSON (Object o)

292− "service_account" -> fail "type: 'service_account' not supported."

293− _ -> fail . Text.unpack $

294− "Unrecognized default credentials type: " <> t

295−

296data Refresh a = Refresh

275data Refresh a = Refresh

297− { _rExpiry :: !UTCTime

298− , _rToken :: !OAuthToken

276+ { _rToken :: !OAuthToken

277+ , _rExpiry :: !UTCTime

299 , _rTarget :: !a

278 , _rTarget :: !a

300 }

279 }

301

280

302−isValid :: Refresh a -> IO Bool

281+instance FromJSON (UTCTime -> (Maybe Text -> a) -> Refresh a) where

303−isValid r = do

282+ parseJSON = withObject "refresh_token" $ \o -> do

304− ts <- getCurrentTime

283+ t <- o .: "access_token"

305− pure $! ts < _rExpiry r

284+ e <- o .: "expires_in" <&> fromInteger

306−

285+ r <- o .:? "refresh_token"

307−data Auth

308− = Tok !OAuthToken

309− | Ref (MVar (Refresh AuthorizedUser))

310− (AuthorizedUser -> IO (Refresh AuthorizedUser))

311−

312−withToken :: MonadIO m => Auth -> (OAuthToken -> m a) -> m a

313−withToken x f = refreshToken x >>= f

314−

315−refreshToken :: MonadIO m => Auth -> m OAuthToken

316−refreshToken = liftIO . \case

317− Tok t -> pure t

286+ pure $ \ts f ->

318− Ref v f -> do

287+ Refresh t (addUTCTime e ts) (f r)

319− x <- readMVar v

288+

320− xv <- isValid x

289+class RefreshToken a where

321− if xv

290+ refresh :: Manager -> a -> IO (Refresh a)

322− then pure (_rToken x)

291+

323− else modifyMVar v $ \y -> do

292+instance RefreshToken User where

324− yv <- isValid y

293+ refresh m u@User {..} = do

325− if yv

294+ rs <- httpLbs rq m

326− then pure (y, _rToken x)

295+ let bs = responseBody rs

327− else do

296+ s = responseStatus rs

328− z <- f (_rTarget y)

297+ if fromEnum s == 200 then success s bs else failure s bs

329− pure (z, _rToken z)

298+ where

330−

299+ failure s bs = do

331−data Credentials

300+ RefreshError {..} <- parseErr s bs

332− = FromToken !OAuthToken

301+ refreshErr s _eError _eDescription

333− | FromFile !FilePath

302+

334− | Discover

303+ success s bs = do

335− deriving (Eq, Show)

304+ f <- parseErr s bs

336−

305+ ts <- getCurrentTime

337−getAuth :: MonadIO m => Manager -> Credentials -> m Auth

306+ pure $! f ts $ \r ->

338−getAuth m = \case

307+ u { _uRefresh = fromMaybe _uRefresh r

339− FromToken t -> pure (Tok t)

308+ }

340− FromFile f -> undefined -- fromFilePath f

309+

341− Discover -> undefined

310+ parseErr s bs =

342− -- catching _MissingFileError fromFile $ \f -> do

311+ case parseLBS bs of

343− -- p <- detectGCE m

312+ Left e -> refreshErr s e Nothing

344− -- unless p $

313+ Right !x -> pure x

345− -- throwingM _MissingFileError f

314+

346− -- fromMetadata m

315+ refreshErr s e = throwM . TokenRefreshError s e

347−

316+

348−-- fromFile :: MonadIO m => m Auth

317+ rq = def

349−-- fromFile = undefined -- defaultCredentialsPath >>= fromFilePath

350−

351−-- fromMetadata :: MonadIO m => Manager -> m Auth

352−-- fromMetadata m = liftIO $ do

353−-- !r <- refresh

354−-- Ref <$> newMVar r <*> pure refresh

355−-- where

356−-- refresh = do

357−-- bs <- httpLbs rq m

358−-- parseLBS

359−

360−-- GOOGLE_AUTH_URI = 'https://accounts.google.com/o/oauth2/auth'

318+ { Client.host = "accounts.google.com"

361−-- GOOGLE_DEVICE_URI = 'https://accounts.google.com/o/oauth2/device/code'

319+ , Client.port = 443

362−-- GOOGLE_REVOKE_URI = 'https://accounts.google.com/o/oauth2/revoke'

320+ , Client.secure = True

363−-- GOOGLE_TOKEN_URI = 'https://accounts.google.com/o/oauth2/token'

321+ , Client.checkStatus = \_ _ _ -> Nothing

364−-- GOOGLE_TOKEN_INFO_URI = 'https://www.googleapis.com/oauth2/v2/tokeninfo'

322+ , Client.method = "POST"

365−

323+ , Client.path = "/o/oauth2/token"

366−-- fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth

324+ , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]

367−-- fromFilePath m f = liftIO $ do

325+ , Client.requestBody = RequestBodyBS . Text.encodeUtf8 $

368−-- p <- doesFileExist f

326+ "grant_type=refresh_token"

369−-- unless p $

327+ <> "&client_id=" <> clientIdToText _uId

370−-- throwM (MissingFileError f)

328+ <> "&client_secret=" <> _uSecret

371−-- !u <- LBS.readFile f >>= either invalidErr pure . eitherDecode'

329+ <> "&refresh_token=" <> _uRefresh

372−-- !r <- refresh m u

330+ }

373−-- Ref <$> newMVar r <*> pure (refresh d)

331+

332+instance RefreshToken ServiceId where

333+ refresh m sid = do

334+ rs <- httpLbs rq m

335+ let bs = responseBody rs

336+ s = responseStatus rs

337+ if fromEnum s == 200 then success s bs else failure s

338+ where

339+ failure s =

340+ refreshErr s "Failure refreshing token from http://metadata.google.internal"

341+ Nothing

342+

343+ success s bs = do

344+ f <- parseErr s bs

345+ ts <- getCurrentTime

346+ pure $! f ts (const sid :: Maybe Text -> ServiceId)

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 = "metadata.google.internal"

357+ , Client.port = 80

358+ , Client.secure = False

359+ , Client.checkStatus = \_ _ _ -> Nothing

360+ , Client.method = "GET"

361+ , Client.path = "/computeMetadata/v1/instance/service-accounts/"

362+ <> Text.encodeUtf8 (serviceIdToText sid)

363+ <> "/token"

364+ }

gogol/src/Network/Google/Env.hs+1−1

@@ -71,4 +71,4 @@ newEnv c = liftIO (newManager tlsManagerSettings) >>= newEnvWith c

72-- | /See:/ 'newEnv'

73newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env

74−newEnvWith c m = Env Nothing m <$> getAuth c

74+newEnvWith c m = Env Nothing m <$> getAuth m c