@@ -1,9 +1,7 @@
1−{-# LANGUAGE BangPatterns #-}
21{-# LANGUAGE DeriveDataTypeable #-}
32{-# LANGUAGE DeriveGeneric #-}
43{-# LANGUAGE FlexibleContexts #-}
54{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GADTs #-}
75{-# LANGUAGE GeneralizedNewtypeDeriving #-}
86{-# LANGUAGE LambdaCase #-}
97{-# LANGUAGE OverloadedStrings #-}
@@ -231,6 +229,8 @@ fromFilePath ss f = do
231229 either (throwM . InvalidFileError f . Text.pack) pure
232230 (fromJSONCredentials ss bs)
233231
232+-- | Attempt to parse either a @service_account@ or @authorized_user@ formatted
233+-- JSON value to obtain credentials.
234234fromJSONCredentials :: [OAuthScope]
235235 -> LBS.ByteString
236236 -> Either String Credentials
@@ -244,57 +244,80 @@ fromJSONCredentials ss bs = do
244244 ", Failed parsing authorized_user: " ++ ye
245245 _ -> x <|> y
246246
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.
247292exchange :: (MonadIO m, MonadCatch m)
248293 => Credentials
249294 -> Logger
250295 -> Manager
251− -> m OAuthToken
252−exchange c l m =
253− case c of
254− FromMetadata s -> metadataToken s l m
255− FromAccount a ss -> serviceAccountToken a ss l m
256− FromClient c' n -> exchangeCode c' n l m
257− FromUser u -> authorizedUserToken u Nothing l m
296+ -> m Auth
297+exchange c l = fmap (Auth c) . action l
298+ where
299+ action = case c of
300+ FromMetadata s -> metadataToken s
301+ FromAccount a ss -> serviceAccountToken a ss
302+ FromClient c n -> exchangeCode c n
303+ FromUser u -> authorizedUserToken u Nothing
258304
305+-- | Refresh an existing 'OAuthToken' using
259306refresh :: (MonadIO m, MonadCatch m)
260− => Credentials
261− -> OAuthToken
307+ => Auth
262308 -> Logger
263309 -> Manager
264− -> m OAuthToken
265−refresh c t l m =
266− case c of
267− FromMetadata s -> metadataToken s l m
268− FromAccount a ss -> serviceAccountToken a ss l m
269− FromClient c _ -> refreshToken c t l m
270− FromUser u -> authorizedUserToken u (_tokenRefresh t) l m
271−
272−-- | A credentials value in one of two possible states, pre-exchange and
273−-- containing a valid, but possibly expired access token.
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−
310+ -> m Auth
311+refresh (Auth c t) l = fmap (Auth c) . action l
312+ where
313+ action = case c of
314+ FromMetadata s -> metadataToken s
315+ FromAccount a ss -> serviceAccountToken a ss
316+ FromClient x _ -> refreshToken x t
317+ FromUser u -> authorizedUserToken u (_tokenRefresh t)
318+
319+-- | Apply the (by way of possible token refresh) a bearer token to the
320+-- authentication header of a request.
298321authorize :: (MonadIO m, MonadCatch m)
299322 => Client.Request
300323 -> Store
@@ -309,26 +332,3 @@ authorize rq s l m = bearer <$> getToken s l m
309332 , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
310333 ) : Client.requestHeaders rq
311334 }
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')