@@ -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 #-}
@@ -30,39 +28,28 @@ module Network.Google.Auth
3028 , fromFilePath
3129 , fromJSONCredentials
3230
33− -- ** Thread-safe Storage
34− , Auth (..)
35− , Store
36− , emptyStore
37−
3831 -- ** Authorizing Requests
3932 , authorize
4033
4134 -- ** Constructing Callback URLs
4235 , formURL
43− , redirectURI
44− , accountsURL
36+
37+ -- ** Thread-safe Storage
38+ , Auth (..)
39+ , Store
40+ , initStore
41+ , exchange
42+ , refresh
4543
4644 -- ** Default Constants
47− -- *** Google Compute Engine
4845 , checkGCEVar
49−
50− -- *** Cloud SDK
5146 , cloudSDKConfigDir
52− , cloudSDKConfigPath
53−
54− -- *** Application Default Credentials
5547 , defaultCredentialsFile
56− , defaultCredentialsPath
5748
5849 -- ** Handling Errors
5950 , AsAuthError (..)
6051 , AuthError (..)
6152
62− -- * Credential Types
63− , ServiceAccount (..)
64− , AuthorizedUser (..)
65−
6653 -- * OAuth Types
6754 , OAuthClient (..)
6855 , OAuthToken (..)
@@ -75,278 +62,56 @@ module Network.Google.Auth
7562 , Secret (..)
7663 , ServiceId (..)
7764 , ClientId (..)
78−
79− -- * Exchange and Refresh Internals
80− , getToken
81− , validateToken
82−
83− , exchange
84− , exchangeCode
85−
86− , refresh
87− , refreshMetadata
88− , refreshToken
89− , refreshAssertion
9065 ) where
9166
9267import Control.Applicative
9368import Control.Concurrent
9469import Control.Exception.Lens
95−import Control.Lens hiding (coerce, (.=))
70+import Control.Lens hiding
71+ (coerce,
72+ (.=))
9673import Control.Monad
9774import Control.Monad.Catch
9875import Control.Monad.IO.Class
99−import Crypto.Hash.Algorithms (SHA256 (..))
100−import Crypto.PubKey.RSA.PKCS15 (signSafer)
101−import Crypto.PubKey.RSA.Types (PrivateKey)
76+import Crypto.Hash.Algorithms (SHA256 (..))
77+import Crypto.PubKey.RSA.PKCS15 (signSafer)
78+import Crypto.PubKey.RSA.Types (PrivateKey)
10279import Data.Aeson
10380import Data.Aeson.Types
10481import Data.ByteArray
10582import Data.ByteArray.Encoding
106−import Data.ByteString (ByteString)
107−import Data.ByteString.Builder (Builder)
108−import qualified Data.ByteString.Builder as Build
109−import qualified Data.ByteString.Char8 as BS8
110−import qualified Data.ByteString.Lazy as LBS
83+import Data.ByteString (ByteString)
84+import Data.ByteString.Builder (Builder)
85+import qualified Data.ByteString.Builder as Build
86+import qualified Data.ByteString.Char8 as BS8
87+import qualified Data.ByteString.Lazy as LBS
11188import Data.Coerce
112−import Data.Default.Class (def)
113−import Data.List (intersperse)
89+import Data.Default.Class (def)
90+import Data.List (intersperse)
11491import Data.String
115−import qualified Data.Text as Text
116−import qualified Data.Text.Encoding as Text
117−import qualified Data.Text.Lazy as LText
118−import qualified Data.Text.Lazy.Builder as TBuild
119−import qualified Data.Text.Lazy.Encoding as LText
92+import qualified Data.Text as Text
93+import qualified Data.Text.Encoding as Text
12094import Data.Time
12195import Data.Time.Clock.POSIX
12296import Data.Typeable
12397import Data.X509
12498import Data.X509.Memory
99+import Network.Google.Auth.ApplicationDefaultCredentials
100+import Network.Google.Auth.Device
101+import Network.Google.Auth.InstalledApplication
102+import Network.Google.Auth.ServiceAccount
125103import Network.Google.Compute.Metadata
104+import Network.Google.Internal.Auth
126105import Network.Google.Internal.Logger
127−import Network.Google.Prelude hiding (buildText)
128−import Network.HTTP.Conduit hiding (Request)
129−import qualified Network.HTTP.Conduit as Client
106+import Network.Google.Prelude
107+import Network.HTTP.Conduit hiding
108+ (Request)
109+import qualified Network.HTTP.Conduit as Client
130110import Network.HTTP.Types
131−import System.Directory (doesFileExist,
132− getHomeDirectory)
133−import System.Environment (lookupEnv)
134−import System.FilePath ((</>))
135−import System.Info (os)
136−
137−-- | 1 hour in seconds.
138−maxTokenLifetimeSeconds :: Int
139−maxTokenLifetimeSeconds = 3600
140−
141−-- | The environment variable name which is used to specify the directory
142−-- containing the @application_default_credentials.json@ generated by @gcloud init@.
143−cloudSDKConfigDir :: String
144−cloudSDKConfigDir = "CLOUDSDK_CONFIG"
145−
146−-- | The environment variable pointing the file with local
147−-- Application Default Credentials.
148−defaultCredentialsFile :: String
149−defaultCredentialsFile = "GOOGLE_APPLICATION_CREDENTIALS"
150−
151−-- | An error thrown when attempting to read AuthN/AuthZ information.
152−data AuthError
153− = RetrievalError HttpException
154− | MissingFileError FilePath
155− | InvalidFileError FilePath Text
156− | TokenRefreshError Status Text (Maybe Text)
157− deriving (Show, Typeable)
158−
159−instance Exception AuthError
160−
161−class AsAuthError a where
162− -- | A general authentication error.
163− _AuthError :: Prism' a AuthError
164− {-# MINIMAL _AuthError #-}
165−
166− -- | An error occured while communicating over HTTP with either then
167− -- local metadata or remote accounts.google.com endpoints.
168− _RetrievalError :: Prism' a HttpException
169−
170− -- | The specified default credentials file could not be found.
171− _MissingFileError :: Prism' a FilePath
172−
173− -- | An error occured parsing the default credentials file.
174− _InvalidFileError :: Prism' a (FilePath, Text)
175−
176− -- | An error occured when attempting to refresh a token.
177− _TokenRefreshError :: Prism' a (Status, Text, Maybe Text)
178−
179− _RetrievalError = _AuthError . _RetrievalError
180− _MissingFileError = _AuthError . _MissingFileError
181− _InvalidFileError = _AuthError . _InvalidFileError
182− _TokenRefreshError = _AuthError . _TokenRefreshError
183−
184−instance AsAuthError SomeException where
185− _AuthError = exception
186−
187−instance AsAuthError AuthError where
188− _AuthError = id
189−
190− _RetrievalError = prism RetrievalError $ \case
191− RetrievalError e -> Right e
192− x -> Left x
193−
194− _MissingFileError = prism MissingFileError $ \case
195− MissingFileError f -> Right f
196− x -> Left x
197−
198− _InvalidFileError = prism
199− (uncurry InvalidFileError)
200− (\case
201− InvalidFileError f e -> Right (f, e)
202− x -> Left x)
203−
204− _TokenRefreshError = prism
205− (\(s, e, d) -> TokenRefreshError s e d)
206− (\case
207− TokenRefreshError s e d -> Right (s, e, d)
208− x -> Left x)
209−
210−-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
211−-- default application credentials filepath.
212−defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
213−defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile)
214−
215−-- | Return the filepath to the Cloud SDK well known file location such as
216−-- @~\/.config\/gcloud\/application_default_credentials.json@.
217−cloudSDKConfigPath :: MonadIO m => m FilePath
218−cloudSDKConfigPath = do
219− m <- liftIO (lookupEnv cloudSDKConfigDir)
220− case m of
221− Just d -> pure $! d </> "application_default_credentials.json"
222− Nothing -> do
223− d <- getConfigDirectory
224− pure $! d </> "gcloud/application_default_credentials.json"
225−
226−getConfigDirectory :: MonadIO m => m FilePath
227−getConfigDirectory = do
228− h <- liftIO getHomeDirectory
229− if os == "windows"
230− then pure h
231− else pure $! h </> ".config"
232−
233−-- | Given a client identifier, client secret, and a list of scopes to authorize,
234−-- construct a URL that can be used to obtain the 'OAuthCode' required to
235−-- instantiate 'FromClient'-style credentials.
236−formURL :: OAuthClient -> [OAuthScope] -> Text
237−formURL OAuthClient{..} ss =
238− LText.toStrict . LText.decodeUtf8 . Build.toLazyByteString $
239− buildText accountsURL
240− <> "?response_type=code"
241− <> "&client_id=" <> buildText _clientId
242− <> "&redirect_uri=" <> buildText redirectURI
243− <> "&scope=" <> queryEncodeScopes ss
244−
245−-- | @urn:ietf:wg:oauth:2.0:oob@.
246−redirectURI :: Text
247−redirectURI = "urn:ietf:wg:oauth:2.0:oob"
248−
249−{-| Service Account credentials which are typically generated/download
250−from the Google Developer console of the following form:
251−
252−@
253−{
254− \"type\": \"service_account\",
255− \"private_key_id\": \"303ad77e5efdf2ce952DFa\",
256− \"private_key\": \"-----BEGIN PRIVATE KEY-----\n...\n\",
257− \"client_email\": \"email@serviceaccount.com\",
258− \"client_id\": \"035-2-310.useraccount.com\"
259−}
260−@
261−
262−The private key is used to sign a JSON Web Token (JWT) of the
263−grant_type @urn:ietf:params:oauth:grant-type:jwt-bearer@, which is sent to
264−'accountsURL' to obtain a valid 'OAuthToken'. This process requires explicitly
265−specifying which 'Scope's the resulting 'OAuthToken' is authorized to access.
266−-}
267−data ServiceAccount = ServiceAccount
268− { _serviceId :: !ClientId
269− , _serviceEmail :: !Text
270− , _serviceKeyId :: !Text
271− , _servicePrivateKey :: !PrivateKey
272− } deriving (Eq, Show)
273−
274−instance FromJSON ServiceAccount where
275− parseJSON = withObject "service_account" $ \o -> do
276− bs <- Text.encodeUtf8 <$> o .: "private_key"
277− k <- case listToMaybe (readKeyFileFromMemory bs) of
278− Just (PrivKeyRSA k) -> pure k
279− _ ->
280− fail "Unable to parse key contents from \"private_key\""
281− ServiceAccount
282− <$> o .: "client_id"
283− <*> o .: "client_email"
284− <*> o .: "private_key_id"
285− <*> pure k
286−
287−{-| Authorized User credentials which are typically generated by the Cloud SDK
288−Tools such as @gcloud init@, of the following form:
289−
290−@
291−{
292− \"type\": \"authorized_user\",
293− \"client_id\": \"32555940559.apps.googleusercontent.com\",
294− \"client_secret\": \"Zms2qjJy2998hD4CTg2ejr2\",
295− \"refresh_token\": \"1/B3gM1x35v.VtqffS1n5w-rSJ\"
296−}
297−@
298−
299−The secret and refresh token are used to obtain a valid 'OAuthToken' from
300−'accountsURL' using grant_type @refresh_token@.
301−-}
302−data AuthorizedUser = AuthorizedUser
303− { _userId :: !ClientId
304− , _userRefresh :: !RefreshToken
305− , _userSecret :: !Secret
306− } deriving (Eq, Show)
307−
308−instance FromJSON AuthorizedUser where
309− parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser
310− <$> o .: "client_id"
311− <*> o .: "refresh_token"
312− <*> o .: "client_secret"
313−
314−-- | A client identifier and accompanying secret used to obtain/refresh a token.
315−data OAuthClient = OAuthClient
316− { _clientId :: !ClientId
317− , _clientSecret :: !Secret
318− } deriving (Eq, Show)
319−
320−{-| An OAuth bearer type token of the following form:
321−
322−@
323−{
324− \"token_type\": \"Bearer\",
325− \"access_token\": \"eyJhbGci...\",
326− \"refresh_token\": \"1/B3gq9K...\",
327− \"expires_in\": 3600,
328− ...
329−}
330−@
331−
332−The '_tokenAccess' field will be inserted verbatim into the
333−@Authorization: Bearer ...@ header for all HTTP requests.
334−-}
335−data OAuthToken = OAuthToken
336− { _tokenAccess :: !AccessToken
337− , _tokenRefresh :: !(Maybe RefreshToken)
338− , _tokenExpiry :: !UTCTime
339− } deriving (Eq, Show)
340−
341−instance FromJSON (UTCTime -> OAuthToken) where
342− parseJSON = withObject "bearer" $ \o -> do
343− t <- o .: "access_token"
344− r <- o .:? "refresh_token"
345− e <- o .: "expires_in" <&> fromInteger
346− pure (OAuthToken t r . addUTCTime e)
347−
348−newtype OAuthCode = OAuthCode { codeToText :: Text }
349− deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
111+import System.Directory (doesFileExist, getHomeDirectory)
112+import System.Environment (lookupEnv)
113+import System.FilePath ((</>))
114+import System.Info (os)
350115
351116-- | The supported credential mechanisms.
352117data Credentials
@@ -375,24 +140,6 @@ data Credentials
375140 -- An 'AuthorizedUser' is typically created by the @gcloud init@ command
376141 -- of the Google CloudSDK Tools.
377142
378−-- | A credentials value in one of two possible states, pre-exchange and
379−-- containing a valid, but possibly expired access token.
380−data Auth
381− = Exchange !Credentials
382− -- ^ Signifies that the initial token refresh has not occured, and the
383− -- 'Credentials' need to be signed and exchanged for a valid 'OAuthToken'.
384−
385− | Refresh !Credentials !OAuthToken
386− -- ^ An 'OAuthToken' that can potentially be expired, with the original
387− -- credentials that can be used to perform a refresh.
388−
389−type Store = MVar Auth
390−
391−-- | Construct storage containing the credentials which have not yet been
392−-- exchanged or refreshed.
393−emptyStore :: MonadIO m => Credentials -> m Store
394−emptyStore !c = liftIO . newMVar $ Exchange c
395−
396143-- | Attempt credentials discovery via the following steps:
397144--
398145-- * Read the default credentials from a file specified by
@@ -459,6 +206,8 @@ fromFilePath ss f = do
459206 either (throwM . InvalidFileError f . Text.pack) pure
460207 (fromJSONCredentials ss bs)
461208
209+-- | Attempt to parse either a @service_account@ or @authorized_user@ formatted
210+-- JSON value to obtain credentials.
462211fromJSONCredentials :: [OAuthScope]
463212 -> LBS.ByteString
464213 -> Either String Credentials
@@ -472,21 +221,31 @@ fromJSONCredentials ss bs = do
472221 ", Failed parsing authorized_user: " ++ ye
473222 _ -> x <|> y
474223
475−authorize :: (MonadIO m, MonadCatch m)
476− => Client.Request
477− -> Store
224+-- | An 'OAuthToken' that can potentially be expired, with the original
225+-- credentials that can be used to perform a refresh.
226+data Auth = Auth
227+ { _credentials :: !Credentials
228+ , _token :: !OAuthToken
229+ }
230+
231+-- | Check if the given token is still valid, ie. younger than the projected
232+-- expiry time.
233+validate :: MonadIO m => Auth -> m Bool
234+validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime
235+
236+type Store = MVar Auth
237+
238+-- | Construct storage containing the credentials which have not yet been
239+-- exchanged or refreshed.
240+initStore :: (MonadIO m, MonadCatch m)
241+ => Credentials
478242 -> Logger
479243 -> Manager
480− -> m Client.Request
481−authorize rq s l m = bearer <$> getToken s l m
482− where
483− bearer t = rq
484− { Client.requestHeaders =
485− ( hAuthorization
486− , "Bearer " <> Text.encodeUtf8 (accessToText (_tokenAccess t))
487− ) : Client.requestHeaders rq
488− }
244+ -> m Store
245+initStore c l m = exchange c l m >>= liftIO . newMVar
489246
247+-- | Concurrently read the current token, and if expired, then
248+-- safely perform a single serial refresh.
490249getToken :: (MonadIO m, MonadCatch m)
491250 => Store
492251 -> Logger
@@ -494,255 +253,59 @@ getToken :: (MonadIO m, MonadCatch m)
494253 -> m OAuthToken
495254getToken s l m = do
496255 x <- liftIO (readMVar s)
497− mx <- validateToken x
498− case mx of
499− Just t -> pure t
500− Nothing -> liftIO . modifyMVar s $ \y -> do
501− my <- validateToken y
502− case my of
503− Just t -> pure (y, t)
504− Nothing ->
505− case y of
506− Exchange c -> do
507− t <- exchange c l m
508− pure (Refresh c t, t)
509− Refresh c t -> do
510− t' <- refresh c t l m
511− pure (Refresh c t', t')
512−
513−validateToken :: MonadIO m => Auth -> m (Maybe OAuthToken)
514−validateToken Exchange {} = pure Nothing
515−validateToken (Refresh _ t) = do
516− ts <- liftIO getCurrentTime
517− if ts < _tokenExpiry t
518− then pure (Just t)
519− else pure Nothing
520−
256+ mx <- validate x
257+ if mx
258+ then pure (_token x)
259+ else liftIO . modifyMVar s $ \y -> do
260+ my <- validate y
261+ if my
262+ then pure (y, _token y)
263+ else do
264+ z <- refresh y l m
265+ pure (z, _token z)
266+
267+-- | Perform the initial credentials exchange to obtain a valid 'OAuthToken'
268+-- suitable for authorizing requests.
521269exchange :: (MonadIO m, MonadCatch m)
522270 => Credentials
523271 -> Logger
524272 -> Manager
525− -> m OAuthToken
526−exchange c l m =
527− case c of
528− FromMetadata s -> refreshMetadata s l m
529− FromAccount a ss -> refreshAssertion a ss l m
530− FromClient c' n -> exchangeCode c' n l m
531− FromUser AuthorizedUser{..} ->
532− refreshToken _userId _userSecret (Just _userRefresh) l m
533−
534−exchangeCode :: (MonadIO m, MonadCatch m)
535− => OAuthClient
536− -> OAuthCode
537− -> Logger
538− -> Manager
539− -> m OAuthToken
540−exchangeCode OAuthClient{..} n = refreshRequest $
541− accountsRequest
542− { Client.requestBody = buildBody $
543− "grant_type=authorization_code"
544− <> "&client_id=" <> buildText _clientId
545− <> "&client_secret=" <> buildText _clientSecret
546− <> "&code=" <> buildText n
547− <> "&redirect_uri=" <> buildText redirectURI
548− }
273+ -> m Auth
274+exchange c l = fmap (Auth c) . action l
275+ where
276+ action = case c of
277+ FromMetadata s -> metadataToken s
278+ FromAccount a ss -> serviceAccountToken a ss
279+ FromClient c n -> exchangeCode c n
280+ FromUser u -> authorizedUserToken u Nothing
549281
282+-- | Refresh an existing 'OAuthToken' using
550283refresh :: (MonadIO m, MonadCatch m)
551− => Credentials
552− -> OAuthToken
284+ => Auth
553285 -> Logger
554286 -> Manager
555− -> m OAuthToken
556−refresh c OAuthToken{..} l m =
557− case c of
558− FromMetadata s -> refreshMetadata s l m
559− FromAccount a ss -> refreshAssertion a ss l m
560− FromClient OAuthClient{..} _ ->
561− refreshToken _clientId _clientSecret _tokenRefresh l m
562− FromUser AuthorizedUser{..} ->
563− refreshToken _userId _userSecret
564− (_tokenRefresh <|> Just _userRefresh) l m
565−
566−refreshMetadata :: (MonadIO m, MonadCatch m)
567− => ServiceId
568− -> Logger
569− -> Manager
570− -> m OAuthToken
571−refreshMetadata s = refreshRequest $
572− metadataRequest
573− { Client.path = "instance/service-accounts/"
574− <> Text.encodeUtf8 (serviceIdToText s)
575− <> "/token"
576− }
577−
578−refreshToken :: (MonadIO m, MonadCatch m)
579− => ClientId
580− -> Secret
581− -> Maybe RefreshToken
582− -> Logger
583− -> Manager
584− -> m OAuthToken
585−refreshToken c s r = refreshRequest $
586− accountsRequest
587− { Client.requestBody = buildBody $
588− "grant_type=refresh_token"
589− <> "&client_id=" <> buildText c
590− <> "&client_secret=" <> buildText s
591− <> maybe mempty ("&refresh_token=" <>) (buildText <$> r)
592− }
593−
594−refreshAssertion :: (MonadIO m, MonadCatch m)
595− => ServiceAccount
596− -> [OAuthScope]
597− -> Logger
598− -> Manager
599− -> m OAuthToken
600−refreshAssertion s ss l m = do
601− b <- encodeJWTBearer s ss
602− let rq = accountsRequest
603− { Client.requestBody = buildBody $
604− "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"
605− <> "&assertion="
606− <> Build.byteString b
607− }
608− refreshRequest rq l m
609−
610−encodeJWTBearer :: (MonadIO m, MonadThrow m)
611− => ServiceAccount
612− -> [OAuthScope]
613− -> m ByteString
614−encodeJWTBearer s ss = liftIO $ do
615− i <- input . truncate <$> getPOSIXTime
616− r <- signSafer (Just SHA256) (_servicePrivateKey s) i
617− either failure (pure . concat' i) r
287+ -> m Auth
288+refresh (Auth c t) l = fmap (Auth c) . action l
618289 where
619− concat' i x = i <> "." <> signature (base64 x)
620−
621− failure e = throwM $
622− TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing
623−
624− signature bs =
625− case BS8.unsnoc bs of
626− Nothing -> mempty
627− Just (bs', x)
628− | x == '=' -> bs'
629− | otherwise -> bs
630−
631− input n = header <> "." <> payload
632− where
633− header = base64Encode
634− [ "alg" .= ("RS256" :: Text)
635− , "typ" .= ("JWT" :: Text)
636− , "kid" .= _serviceKeyId s
637− ]
638−
639− payload = base64Encode
640− [ "aud" .= accountsURL
641− , "scope" .= concatScopes ss
642− , "iat" .= n
643− , "exp" .= (n + maxTokenLifetimeSeconds)
644− , "iss" .= _serviceEmail s
645− ]
646−
647−-- | @https://accounts.google.com/o/oauth2/token@.
648−accountsURL :: Text
649−accountsURL = "https://accounts.google.com/o/oauth2/token"
650−
651−accountsRequest :: Client.Request
652−accountsRequest = def
653− { Client.host = "accounts.google.com"
654− , Client.port = 443
655− , Client.secure = True
656− , Client.checkStatus = \_ _ _ -> Nothing
657− , Client.method = "POST"
658− , Client.path = "/o/oauth2/token"
659− , Client.requestHeaders =
660− [ (hContentType, "application/x-www-form-urlencoded")
661− ]
662− }
663−
664−refreshRequest :: (MonadIO m, MonadCatch m)
665− => Client.Request
666− -> Logger
667− -> Manager
668− -> m OAuthToken
669−refreshRequest rq l m = do
670− logDebug l rq -- debug:ClientRequest
671−
672− rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)
673−
674− let bs = responseBody rs
675− s = responseStatus rs
676−
677− logDebug l rs -- debug:ClientResponse
678− logTrace l $ "[Response Body]\n" <> bs -- trace:ResponseBody
679−
680− if fromEnum s == 200
681− then success s bs
682− else failure s bs
290+ action = case c of
291+ FromMetadata s -> metadataToken s
292+ FromAccount a ss -> serviceAccountToken a ss
293+ FromClient x _ -> refreshToken x t
294+ FromUser u -> authorizedUserToken u (_tokenRefresh t)
295+
296+-- | Apply the (by way of possible token refresh) a bearer token to the
297+-- authentication header of a request.
298+authorize :: (MonadIO m, MonadCatch m)
299+ => Client.Request
300+ -> Store
301+ -> Logger
302+ -> Manager
303+ -> m Client.Request
304+authorize rq s l m = bearer <$> getToken s l m
683305 where
684− success s bs = do
685− f <- parseErr s bs
686− ts <- liftIO getCurrentTime
687− pure (f ts)
688−
689− failure s bs = do
690− let e = "Failure refreshing token from " <> host <> path
691− logError l $ "[Refresh Error] " <> build e
692− case parseLBS bs of
693− Right x -> refreshErr s (_error x) (_description x)
694− Left _ -> refreshErr s e Nothing
695−
696− parseErr s bs =
697− case parseLBS bs of
698− Right !x -> pure x
699− Left e -> do
700− logError l $
701− "[Parse Error] Failure parsing token refresh " <> build e
702− refreshErr s e Nothing
703−
704− refreshErr :: MonadThrow m => Status -> Text -> Maybe Text -> m a
705− refreshErr s e = throwM . TokenRefreshError s e
706−
707− host = Text.decodeUtf8 (Client.host rq)
708− path = Text.decodeUtf8 (Client.path rq)
709−
710−parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
711−parseLBS = either (Left . Text.pack) Right . eitherDecode'
712−
713−base64Encode :: [Pair] -> ByteString
714−base64Encode = base64 . LBS.toStrict . encode . object
715−
716−base64 :: ByteArray a => a -> ByteString
717−base64 = convertToBase Base64URLUnpadded
718−
719−buildBody :: Builder -> RequestBody
720−buildBody = RequestBodyLBS . Build.toLazyByteString
721−
722−buildText :: ToText a => a -> Builder
723−buildText = build . toText
724−
725−queryEncodeScopes :: [OAuthScope] -> Build.Builder
726−queryEncodeScopes =
727− mconcat
728− . intersperse "+"
729− . map (urlEncodeBuilder True . Text.encodeUtf8)
730− . coerce
731−
732−concatScopes :: [OAuthScope] -> LText.Text
733−concatScopes =
734− TBuild.toLazyText
735− . mconcat
736− . intersperse " "
737− . map TBuild.fromText
738− . coerce
739−
740−data RefreshError = RefreshError
741− { _error :: !Text
742− , _description :: !(Maybe Text)
743− }
744−
745−instance FromJSON RefreshError where
746− parseJSON = withObject "refresh_error" $ \o -> RefreshError
747− <$> o .: "error"
748− <*> o .:? "error_description"
306+ bearer t = rq
307+ { Client.requestHeaders =
308+ ( hAuthorization
309+ , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
310+ ) : Client.requestHeaders rq
311+ }