d8fbce4 · gogol · git.iko.soy

git.iko.soy/gogol

on develop help sign in

Reformatting

d8fbce4Brendan Hay11 years ago

gogol/src/Network/Google/Auth.hs+68−68

compare with develop

unifiedsplit

@@ -1,9 +1,7 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

@@ -231,6 +229,8 @@ fromFilePath ss f = do

231 either (throwM . InvalidFileError f . Text.pack) pure

229 either (throwM . InvalidFileError f . Text.pack) pure

232 (fromJSONCredentials ss bs)

230 (fromJSONCredentials ss bs)

233

231

232+-- | Attempt to parse either a @service_account@ or @authorized_user@ formatted

233+-- JSON value to obtain credentials.

234fromJSONCredentials :: [OAuthScope]

235 -> LBS.ByteString

236 -> Either String Credentials

@@ -244,57 +244,80 @@ fromJSONCredentials ss bs = do

244 ", Failed parsing authorized_user: " ++ ye

245 _ -> x <|> y

246

247+-- | An 'OAuthToken' that can potentially be expired, with the original

248+-- credentials that can be used to perform a refresh.

249+data Auth = Auth

250+ { _credentials :: !Credentials

251+ , _token :: !OAuthToken

252+ }

253+

254+-- | Check if the given token is still valid, ie. younger than the projected

255+-- expiry time.

256+validate :: MonadIO m => Auth -> m Bool

257+validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime

258+

259+type Store = MVar Auth

260+

261+-- | Construct storage containing the credentials which have not yet been

262+-- exchanged or refreshed.

263+initStore :: (MonadIO m, MonadCatch m)

264+ => Credentials

265+ -> Logger

266+ -> Manager

267+ -> m Store

268+initStore c l m = exchange c l m >>= liftIO . newMVar

269+

270+-- | Concurrently read the current token, and if expired, then

271+-- safely perform a single serial refresh.

272+getToken :: (MonadIO m, MonadCatch m)

273+ => Store

274+ -> Logger

275+ -> Manager

276+ -> m OAuthToken

277+getToken s l m = do

278+ x <- liftIO (readMVar s)

279+ mx <- validate x

280+ if mx

281+ then pure (_token x)

282+ else liftIO . modifyMVar s $ \y -> do

283+ my <- validate y

284+ if my

285+ then pure (y, _token y)

286+ else do

287+ z <- refresh y l m

288+ pure (z, _token z)

289+

290+-- | Perform the initial credentials exchange to obtain a valid 'OAuthToken'

291+-- suitable for authorizing requests.

247exchange :: (MonadIO m, MonadCatch m)

292exchange :: (MonadIO m, MonadCatch m)

248 => Credentials

293 => Credentials

249 -> Logger

294 -> Logger

250 -> Manager

295 -> Manager

251− -> m OAuthToken

296+ -> m Auth

252−exchange c l m =

297+exchange c l = fmap (Auth c) . action l

298+ where

253− case c of

299+ action = case c of

254− FromMetadata s -> metadataToken s l m

300+ FromMetadata s -> metadataToken s

255− FromAccount a ss -> serviceAccountToken a ss l m

301+ FromAccount a ss -> serviceAccountToken a ss

256− FromClient c' n -> exchangeCode c' n l m

302+ FromClient c n -> exchangeCode c n

257− FromUser u -> authorizedUserToken u Nothing l m

303+ FromUser u -> authorizedUserToken u Nothing

258

304

305+-- | Refresh an existing 'OAuthToken' using

259refresh :: (MonadIO m, MonadCatch m)

306refresh :: (MonadIO m, MonadCatch m)

260− => Credentials

307+ => Auth

261− -> OAuthToken

262 -> Logger

308 -> Logger

263 -> Manager

309 -> Manager

264− -> m OAuthToken

310+ -> m Auth

265−refresh c t l m =

311+refresh (Auth c t) l = fmap (Auth c) . action l

312+ where

266− case c of

313+ action = case c of

267− FromMetadata s -> metadataToken s l m

314+ FromMetadata s -> metadataToken s

268− FromAccount a ss -> serviceAccountToken a ss l m

315+ FromAccount a ss -> serviceAccountToken a ss

269− FromClient c _ -> refreshToken c t l m

316+ FromClient x _ -> refreshToken x t

270− FromUser u -> authorizedUserToken u (_tokenRefresh t) l m

317+ FromUser u -> authorizedUserToken u (_tokenRefresh t)

271−

318+

272−-- | A credentials value in one of two possible states, pre-exchange and

319+-- | Apply the (by way of possible token refresh) a bearer token to the

273−-- containing a valid, but possibly expired access token.

320+-- authentication header of a request.

274−data Auth

275− = Exchange !Credentials

276− -- ^ Signifies that the initial token refresh has not occured, and the

277− -- 'Credentials' need to be signed and exchanged for a valid 'OAuthToken'.

278−

279− | Refresh !Credentials !OAuthToken

280− -- ^ An 'OAuthToken' that can potentially be expired, with the original

281− -- credentials that can be used to perform a refresh.

282−

283−validateToken :: MonadIO m => Auth -> m (Maybe OAuthToken)

284−validateToken Exchange {} = pure Nothing

285−validateToken (Refresh _ t) = do

286− ts <- liftIO getCurrentTime

287− if ts < _tokenExpiry t

288− then pure (Just t)

289− else pure Nothing

290−

291−type Store = MVar Auth

292−

293−-- | Construct storage containing the credentials which have not yet been

294−-- exchanged or refreshed.

295−emptyStore :: MonadIO m => Credentials -> m Store

296−emptyStore !c = liftIO . newMVar $ Exchange c

297−

298authorize :: (MonadIO m, MonadCatch m)

321authorize :: (MonadIO m, MonadCatch m)

299 => Client.Request

322 => Client.Request

300 -> Store

323 -> Store

@@ -309,26 +332,3 @@ authorize rq s l m = bearer <$> getToken s l m

309 , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))

332 , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))

310 ) : Client.requestHeaders rq

333 ) : Client.requestHeaders rq

311 }

334 }

312−

313−getToken :: (MonadIO m, MonadCatch m)

314− => Store

315− -> Logger

316− -> Manager

317− -> m OAuthToken

318−getToken s l m = do

319− x <- liftIO (readMVar s)

320− mx <- validateToken x

321− case mx of

322− Just t -> pure t

323− Nothing -> liftIO . modifyMVar s $ \y -> do

324− my <- validateToken y

325− case my of

326− Just t -> pure (y, t)

327− Nothing ->

328− case y of

329− Exchange c -> do

330− t <- exchange c l m

331− pure (Refresh c t, t)

332− Refresh c t -> do

333− t' <- refresh c t l m

334− pure (Refresh c t', t')

gogol/src/Network/Google/Env.hs+9−8

@@ -22,8 +22,8 @@ import Network.HTTP.Conduit

23-- | The environment containing the parameters required to make Google requests.

24data Env = Env

25− { _envLogger :: !Logger

26− , _envOverride :: !(Dual (Endo Service))

25+ { _envOverride :: !(Dual (Endo Service))

26+ , _envLogger :: !Logger

27 , _envManager :: !Manager

28 , _envStore :: !Store

29 }

@@ -35,20 +35,20 @@ class HasEnv a where

35 environment :: Lens' a Env

36 {-# MINIMAL environment #-}

38− -- | The function used to output log messages.

39− envLogger :: Lens' a Logger

40−

41 -- | The currently applied overrides to all 'Service' configuration.

38 -- | The currently applied overrides to all 'Service' configuration.

42 envOverride :: Lens' a (Dual (Endo Service))

39 envOverride :: Lens' a (Dual (Endo Service))

41+ -- | The function used to output log messages.

42+ envLogger :: Lens' a Logger

43+

44 -- | The 'Manager' used to create and manage open HTTP connections.

45 envManager :: Lens' a Manager

47 -- | The credential store used to sign requests for authentication with Google.

48 envStore :: Lens' a Store

50− envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a })

51 envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })

50 envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })

51+ envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a })

52 envManager = environment . lens _envManager (\s a -> s { _envManager = a })

53 envStore = environment . lens _envStore (\s a -> s { _envStore = a })

@@ -117,7 +117,7 @@ newEnv :: (MonadIO m, MonadCatch m) => [OAuthScope] -> m Env

117newEnv ss = do

118 m <- liftIO (newManager tlsManagerSettings)

119 c <- discover ss m

120− newEnvWith c m

120+ newEnvWith c (\_ _ -> pure ()) m

121

122-- | Creates a new environment without logging, using the supplied 'Manager' and

123-- credentials. Use either the 'Credentials' constructor or

@@ -135,6 +135,7 @@ newEnv ss = do

135-- /See:/ 'newEnv'.

136newEnvWith :: (MonadIO m, MonadCatch m)

137 => Credentials

138+ -> Logger

138 -> Manager

139 -> Manager

139 -> m Env

140 -> m Env

140−newEnvWith c m = Env (\_ _ -> pure ()) mempty m <$> emptyStore c

141+newEnvWith c l m = Env mempty l m <$> initStore c l m