git.iko.soy/gogol
on develop help sign in
Adding type families and scope allow/authorize primitives
commit033fe2c3e2655b64c86e6094307893770b63e402 authorBrendan Hay <brendan.g.hay@gmail.com> dateFri 30 Oct 2015, 17:18 (11 years ago) parent86fdee2
7 files changed+503−399
compare with develop
unifiedsplit
gogol/gogol.cabal+1 gogol/src/Network/Google.hs+170−175 gogol/src/Network/Google/Auth.hs+133−137 gogol/src/Network/Google/Auth/Scope.hs+126 gogol/src/Network/Google/Env.hs+56−67 gogol/src/Network/Google/Internal/Auth.hs+13−18 gogol/src/Network/Google/Internal/HTTP.hs+4−2
gogol/gogol.cabal+1
@@ -41,6 +41,7 @@ library
4141 exposed-modules:
4242 Network.Google
4343 , Network.Google.Auth
44+ , Network.Google.Auth.Scope
4445 , Network.Google.Auth.ApplicationDefault
4546 , Network.Google.Auth.Device
4647 , Network.Google.Auth.InstalledApplication
gogol/src/Network/Google.hs+170−175
@@ -1,8 +1,10 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
45{-# LANGUAGE GeneralizedNewtypeDeriving #-}
56{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
68{-# LANGUAGE ScopedTypeVariables #-}
79{-# LANGUAGE TypeFamilies #-}
810{-# LANGUAGE UndecidableInstances #-}
@@ -24,71 +26,75 @@
2426-- A 'MonadGoogle' typeclass is used as a function constraint to provide automatic
2527-- lifting of functions when embedding 'Google' as a layer inside your own
2628-- application stack.
27−module Network.Google where
28− -- (
29− -- -- * Running Google Actions
30− -- Google (..)
31− -- , MonadGoogle (..)
32− -- , runGoogle
33− -- , runResourceT
29+module Network.Google
30+ (
31+ -- * Running Google Actions
32+ Google (..)
33+ , MonadGoogle (..)
34+ , runGoogle
35+ , runResourceT
3436
35− -- -- * Authentication and Environment
36− -- , newEnv
37− -- , Env
38− -- , HasEnv (..)
37+ -- * Authentication and Environment
38+ , Env
39+ , HasEnv (..)
40+ , newEnv
3941
40− -- -- * Sending Requests
41− -- , send
42+ -- ** Customized Environment
43+ , newEnvWith
44+ , getApplicationDefault
4245
43− -- -- ** Media Downloads
44− -- , download
46+ -- * Sending Requests
47+ , send
4548
46− -- -- ** Media Uploads
47− -- , upload
49+ -- ** Media Downloads
50+ , download
4851
49− -- , ToBody (..)
50− -- , RequestBody
51− -- , sourceBody
52+ -- ** Media Uploads
53+ , upload
5254
53− -- -- ** Service Configuration
54− -- -- ** Overriding Defaults
55− -- , configure
56− -- , override
55+ , ToBody (..)
56+ , RequestBody
57+ , sourceBody
5758
58− -- -- *** Scoped Actions
59− -- , reconfigure
60− -- , timeout
59+ -- ** Service Configuration
60+ -- ** Overriding Defaults
61+ , configure
62+ , override
6163
62− -- -- * Running Asynchronous Actions
63− -- -- $async
64+ -- *** Scoped Actions
65+ , reconfigure
66+ , timeout
6467
65− -- -- * Handling Errors
66− -- , AsError (..)
67− -- , AsAuthError (..)
68+ -- * Running Asynchronous Actions
69+ -- $async
6870
69− -- , trying
70− -- , catching
71+ -- * Handling Errors
72+ , AsError (..)
73+ , AsAuthError (..)
7174
72− -- -- * Logging
73− -- -- $logging
75+ , trying
76+ , catching
7477
75− -- , Logger
76− -- , LogLevel (..)
78+ -- * Logging
79+ -- $logging
7780
78− -- -- ** Constructing a Logger
79− -- , newLogger
81+ , Logger
82+ , LogLevel (..)
8083
81− -- -- * Constructing a HTTP Manager
82− -- , newManager
83− -- , tlsManagerSettings
84+ -- ** Constructing a Logger
85+ , newLogger
8486
85− -- -- * Re-exported Types
86− -- , Proxy (..)
87− -- , OctetStream
88− -- , PlainText
89− -- , JSON
90− -- , module Network.Google.Types
91− -- ) where
87+ -- * Constructing a HTTP Manager
88+ , newManager
89+ , tlsManagerSettings
90+
91+ -- * Re-exported Types
92+ , Proxy (..)
93+ , OctetStream
94+ , PlainText
95+ , JSON
96+ , module Network.Google.Types
97+ ) where
9298
9399import Control.Applicative
94100import Control.Exception.Lens
@@ -129,131 +135,120 @@ newtype Google s a = Google { unGoogle :: ReaderT (Env s) (ResourceT IO) a }
129135 , MonadCatch
130136 , MonadMask
131137 , MonadBase IO
132−-- , MonadReader (Env s)
138+ , MonadReader (Env s)
133139 , MonadResource
134140 )
135141
136−-- | Run a 'Google' aciton using the specified environment.
137−-- runGoogle :: (MonadResource m, HasEnv s r) => r -> Google s a -> m a
138−-- runGoogle e m = liftResourceT $ runReaderT (unGoogle m) (e ^. environment)
139−
140−runGoogle :: MonadResource m => Env s -> Google s a -> m a
141−runGoogle e m = liftResourceT $ runReaderT (unGoogle m) e
142−
143−test :: IO ()
144−test = runResourceT $ do
145− e <- newEnv
146− runGoogle e $ do
147− Bar <- send Foo
148− pure ()
149−
150−send :: (GoogleRequest a, IsSubList s (Ss a)) => a -> Google s (Rs a)
151−send = undefined
152−
153−-- do
154− -- e <- ask
155− -- r <- perform e x
156− -- hoistError r
157−
158−data Foo = Foo
159−data Bar = Bar
160−
161−instance GoogleRequest Foo where
162− type Rs Foo = Bar
163− type Ss Foo = '[Foo]
164−
165− requestClient = undefined
166−
167−
168−-- instance MonadBaseControl IO Google where
169−-- type StM Google a = StM (ReaderT Env (ResourceT IO)) a
170−
171−-- liftBaseWith f = Google . liftBaseWith $ \g -> f (g . unGoogle)
172−-- restoreM = Google . restoreM
173−
174−-- -- | Monads in which 'Google' actions may be embedded.
175−-- class ( Functor m
176−-- , Applicative m
177−-- , Monad m
178−-- , MonadIO m
179−-- , MonadCatch m
180−-- ) => MonadGoogle m where
181−-- -- | Lift a computation to the 'Google' monad.
182−-- liftGoogle :: Google a -> m a
183−
184−-- instance MonadGoogle Google where
185−-- liftGoogle = id
186−
187−-- instance MonadGoogle m => MonadGoogle (IdentityT m) where liftGoogle = lift . liftGoogle
188−-- instance MonadGoogle m => MonadGoogle (ListT m) where liftGoogle = lift . liftGoogle
189−-- instance MonadGoogle m => MonadGoogle (MaybeT m) where liftGoogle = lift . liftGoogle
190−-- instance MonadGoogle m => MonadGoogle (ExceptT e m) where liftGoogle = lift . liftGoogle
191−-- instance MonadGoogle m => MonadGoogle (ReaderT r m) where liftGoogle = lift . liftGoogle
192−-- instance MonadGoogle m => MonadGoogle (S.StateT s m) where liftGoogle = lift . liftGoogle
193−-- instance MonadGoogle m => MonadGoogle (LS.StateT s m) where liftGoogle = lift . liftGoogle
194−
195−-- instance (Monoid w, MonadGoogle m) => MonadGoogle (W.WriterT w m) where
196−-- liftGoogle = lift . liftGoogle
197−
198−-- instance (Monoid w, MonadGoogle m) => MonadGoogle (LW.WriterT w m) where
199−-- liftGoogle = lift . liftGoogle
200−
201−-- instance (Monoid w, MonadGoogle m) => MonadGoogle (RW.RWST r w s m) where
202−-- liftGoogle = lift . liftGoogle
203−
204−-- instance (Monoid w, MonadGoogle m) => MonadGoogle (LRW.RWST r w s m) where
205−-- liftGoogle = lift . liftGoogle
206−
207−-- -- | Run a 'Google' aciton using the specified environment.
208−-- runGoogle :: (MonadResource m, HasEnv r) => r -> Google a -> m a
209−-- runGoogle e m = liftResourceT $ runReaderT (unGoogle m) (e ^. environment)
210−
211−-- -- | Send a request, returning the associated response if successful.
212−-- --
213−-- -- Throws 'Error'.
214−-- send :: (MonadGoogle m, GoogleRequest a) => a -> m (Rs a)
215−-- send x = liftGoogle $ do
216−-- e <- ask
217−-- r <- perform e x
218−-- hoistError r
219−
220−-- -- | Send a request returning the associated streaming media response if successful.
221−-- --
222−-- -- Some request data types have two possible responses, the JSON metadata and
223−-- -- a streaming media response. Use 'send' to retrieve the metadata and 'download'
224−-- -- to retrieve the streaming media.
225−-- --
226−-- -- Throws 'Error'.
227−-- download :: (MonadGoogle m, GoogleRequest (MediaDownload a))
228−-- => a
229−-- -> m (Rs (MediaDownload a))
230−-- download = send . MediaDownload
231−
232−-- -- | Send a request with an attached multipart/related media upload.
233−-- --
234−-- -- Throws 'Error'.
235−-- upload :: (MonadGoogle m, GoogleRequest (MediaUpload a))
236−-- => a
237−-- -> RequestBody
238−-- -> m (Rs (MediaUpload a))
239−-- upload x = send . MediaUpload x
240−
241−-- hoistError :: MonadThrow m => Either Error a -> m a
242−-- hoistError = either (throwingM _Error) return
243−
244−-- {- $async
245−-- Requests can be sent asynchronously, but due to guarantees about resource closure
246−-- require the use of <http://hackage.haskell.org/package/lifted-async lifted-async>.
247−-- -}
248−
249−-- {- $logging
250−-- The exposed logging interface is a primitive 'Logger' function which gets
251−-- threaded through service calls and serialisation routines. This allows the
252−-- library to output useful information and diagnostics.
253−
254−-- The 'newLogger' function can be used to construct a simple logger which writes
255−-- output to a 'Handle', but in most production code you should probably consider
256−-- using a more robust logging library such as
257−-- <http://hackage.haskell.org/package/tiny-log tiny-log> or
258−-- <http://hackage.haskell.org/package/fast-logger fast-logger>.
259−-- -}
142+-- | Run a 'Google' aciton using the specified environment containing
143+-- credentials with sufficient authorization scopes.
144+runGoogle :: (MonadResource m, HasEnv s r) => r -> Google s a -> m a
145+runGoogle e m = liftResourceT $ runReaderT (unGoogle m) (e ^. environment)
146+
147+-- | Monads in which 'Google' actions may be embedded.
148+class ( Allow s
149+ , Functor m
150+ , Applicative m
151+ , Monad m
152+ , MonadIO m
153+ , MonadCatch m
154+ ) => MonadGoogle s m | m -> s where
155+ -- | Lift a computation to the 'Google' monad.
156+ liftGoogle :: Google s a -> m a
157+
158+instance Allow s => MonadGoogle s (Google s) where
159+ liftGoogle = id
160+
161+instance MonadBaseControl IO (Google s) where
162+ type StM (Google s) a = StM (ReaderT (Env s) (ResourceT IO)) a
163+
164+ liftBaseWith f = Google . liftBaseWith $ \g -> f (g . unGoogle)
165+ restoreM = Google . restoreM
166+
167+instance MonadGoogle s m => MonadGoogle s (IdentityT m) where
168+ liftGoogle = lift . liftGoogle
169+
170+instance MonadGoogle s m => MonadGoogle s (ListT m) where
171+ liftGoogle = lift . liftGoogle
172+
173+instance MonadGoogle s m => MonadGoogle s (MaybeT m) where
174+ liftGoogle = lift . liftGoogle
175+
176+instance MonadGoogle s m => MonadGoogle s (ExceptT e m) where
177+ liftGoogle = lift . liftGoogle
178+
179+instance MonadGoogle s m => MonadGoogle s (ReaderT r m) where
180+ liftGoogle = lift . liftGoogle
181+
182+instance MonadGoogle s m => MonadGoogle s (S.StateT s' m) where
183+ liftGoogle = lift . liftGoogle
184+
185+instance MonadGoogle s m => MonadGoogle s (LS.StateT s' m) where
186+ liftGoogle = lift . liftGoogle
187+
188+instance (Monoid w, MonadGoogle s m) => MonadGoogle s (W.WriterT w m) where
189+ liftGoogle = lift . liftGoogle
190+
191+instance (Monoid w, MonadGoogle s m) => MonadGoogle s (LW.WriterT w m) where
192+ liftGoogle = lift . liftGoogle
193+
194+instance (Monoid w, MonadGoogle s m) => MonadGoogle s (RW.RWST r w s' m) where
195+ liftGoogle = lift . liftGoogle
196+
197+instance (Monoid w, MonadGoogle s m) => MonadGoogle s (LRW.RWST r w s' m) where
198+ liftGoogle = lift . liftGoogle
199+
200+-- | Send a request, returning the associated response if successful.
201+--
202+-- Throws 'Error'.
203+send :: (MonadGoogle s m, Authorize s a, GoogleRequest a) => a -> m (Rs a)
204+send x = liftGoogle $ do
205+ e <- ask
206+ r <- perform e x
207+ hoistError r
208+
209+-- | Send a request returning the associated streaming media response if successful.
210+--
211+-- Some request data types have two possible responses, the JSON metadata and
212+-- a streaming media response. Use 'send' to retrieve the metadata and 'download'
213+-- to retrieve the streaming media.
214+--
215+-- Throws 'Error'.
216+download :: ( MonadGoogle s m
217+ , Authorize s (MediaDownload a)
218+ , GoogleRequest (MediaDownload a)
219+ )
220+ => a
221+ -> m (Rs (MediaDownload a))
222+download = send . MediaDownload
223+
224+-- | Send a request with an attached multipart/related media upload.
225+--
226+-- Throws 'Error'.
227+upload :: ( MonadGoogle s m
228+ , Authorize s (MediaUpload a)
229+ , GoogleRequest (MediaUpload a)
230+ )
231+ => a
232+ -> RequestBody
233+ -> m (Rs (MediaUpload a))
234+upload x = send . MediaUpload x
235+
236+hoistError :: MonadThrow m => Either Error a -> m a
237+hoistError = either (throwingM _Error) return
238+
239+{- $async
240+Requests can be sent asynchronously, but due to guarantees about resource closure
241+require the use of <http://hackage.haskell.org/package/lifted-async lifted-async>.
242+-}
243+
244+{- $logging
245+The exposed logging interface is a primitive 'Logger' function which gets
246+threaded through service calls and serialisation routines. This allows the
247+library to output useful information and diagnostics.
248+
249+The 'newLogger' function can be used to construct a simple logger which writes
250+output to a 'Handle', but in most production code you should probably consider
251+using a more robust logging library such as
252+<http://hackage.haskell.org/package/tiny-log tiny-log> or
253+<http://hackage.haskell.org/package/fast-logger fast-logger>.
254+-}
gogol/src/Network/Google/Auth.hs+133−137
@@ -1,5 +1,4 @@
11{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE UndecidableInstances #-}
32{-# LANGUAGE DataKinds #-}
43{-# LANGUAGE DeriveDataTypeable #-}
54{-# LANGUAGE DeriveGeneric #-}
@@ -15,6 +14,7 @@
1514{-# LANGUAGE ScopedTypeVariables #-}
1615{-# LANGUAGE TypeFamilies #-}
1716{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE UndecidableInstances #-}
1818
1919-- |
2020-- Module : Network.Google.Auth
@@ -26,52 +26,55 @@
2626--
2727-- Explicitly specify your Google credentials, or retrieve them
2828-- from the underlying OS.
29−module Network.Google.Auth where
30− -- (
31− -- -- * Credentials
32− -- Credentials (..)
33−
34− -- -- ** Application Default Credentials
35− -- , getApplicationDefault
36− -- , fromWellKnownPath
37− -- , fromFilePath
38−
39− -- -- ** Installed Application Credentials
40− -- , formURL
41−
42− -- -- ** Authorizing Requests
43− -- , authorize
44−
45− -- -- ** Thread-safe Storage
46− -- , Store
47− -- , initStore
48−
49− -- , Auth (..)
50− -- , exchange
51− -- , refresh
52−
53− -- -- ** Default Constants
54− -- , checkGCEVar
55− -- , cloudSDKConfigDir
56− -- , defaultCredentialsFile
57−
58− -- -- ** Handling Errors
59− -- , AsAuthError (..)
60− -- , AuthError (..)
61−
62− -- -- * OAuth Types
63− -- , OAuthClient (..)
64− -- , OAuthToken (..)
65− -- , OAuthCode (..)
66− -- , OAuthScope (..)
67−
68− -- -- * Re-exported Types
69− -- , AccessToken (..)
70− -- , RefreshToken (..)
71− -- , Secret (..)
72− -- , ServiceId (..)
73− -- , ClientId (..)
74− -- ) where
29+module Network.Google.Auth
30+ (
31+ -- * Credentials
32+ Credentials (..)
33+
34+ -- ** Application Default Credentials
35+ , getApplicationDefault
36+ , fromWellKnownPath
37+ , fromFilePath
38+
39+ -- ** Installed Application Credentials
40+ , formURL
41+
42+ -- ** Authorizing Requests
43+ , authorize
44+
45+ -- ** Thread-safe Storage
46+ , Store
47+ , initStore
48+
49+ , Auth (..)
50+ , exchange
51+ , refresh
52+
53+ -- ** Default Constants
54+ , checkGCEVar
55+ , cloudSDKConfigDir
56+ , defaultCredentialsFile
57+
58+ -- ** Handling Errors
59+ , AsAuthError (..)
60+ , AuthError (..)
61+
62+ -- * OAuth Types
63+ , OAuthClient (..)
64+ , OAuthToken (..)
65+ , OAuthCode (..)
66+ , OAuthScope (..)
67+
68+ -- * Re-exported Types
69+ , AccessToken (..)
70+ , RefreshToken (..)
71+ , Secret (..)
72+ , ServiceId (..)
73+ , ClientId (..)
74+
75+ -- * Re-exported Modules
76+ , module Network.Google.Auth.Scope
77+ ) where
7578
7679import Control.Applicative
7780import Control.Concurrent
@@ -100,14 +103,17 @@ import qualified Data.Text as Text
100103import qualified Data.Text.Encoding as Text
101104import Data.Time
102105import Data.Time.Clock.POSIX
106+import Data.Type.Bool
107+import Data.Type.Equality
103108import Data.Typeable
104109import Data.X509
105110import Data.X509.Memory
106111import GHC.Exts (Constraint)
107−import GHC.TypeLits
112+import GHC.TypeLits
108113import Network.Google.Auth.ApplicationDefault
109114import Network.Google.Auth.Device
110115import Network.Google.Auth.InstalledApplication
116+import Network.Google.Auth.Scope
111117import Network.Google.Auth.ServiceAccount
112118import Network.Google.Compute.Metadata
113119import Network.Google.Internal.Auth
@@ -117,106 +123,96 @@ import Network.HTTP.Conduit hiding (Proxy)
117123import qualified Network.HTTP.Conduit as Client
118124import Network.HTTP.Types
119125
120−
121126-- | An 'OAuthToken' that can potentially be expired, with the original
122127-- credentials that can be used to perform a refresh.
123−data Auth (s :: [*]) = Auth
128+data Auth (s :: [Symbol]) = Auth
124129 { _credentials :: !(Credentials s)
125130 , _token :: !OAuthToken
126131 }
127132
128−newtype Store (s :: [*]) = Store { store :: MVar (Auth s) }
129−
130−-- type family HasScope s a :: Constraint where
131−-- HasScope s a = IsSubList s (Ss a)
132−
133−type family And (a :: Constraint) (b :: Constraint) :: Constraint where
134− And () () = ()
135−
136−type family IsSubList a b :: Constraint where
137− IsSubList '[] b = ()
138− IsSubList '[x] (x ': xs) = ()
139− IsSubList '[x] (y ': ys) = IsSubList '[x] ys
140− IsSubList (x ': xs) y = IsSubList '[x] y `And` IsSubList xs y
133+-- | Check if the given token is still valid, ie. younger than the projected
134+-- expiry time.
135+--
136+-- This deliberately makes no external calls due to the absolute construction of
137+-- the '_tokenExpiry' field, unlike the
138+-- <https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken documented>
139+-- validation method.
140+validate :: MonadIO m => Auth s -> m Bool
141+validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime
141142
142−-- authorize :: (MonadIO m, MonadCatch m)
143−-- => Credentials s
144−-- -> Logger
145−-- -> Manager
146−-- -> m (Store s)
147−-- authorize = undefined
143+newtype Store (s :: [Symbol]) = Store (MVar (Auth s))
148144
149145-- | Construct storage containing the credentials which have not yet been
150146-- exchanged or refreshed.
151−initStore :: (MonadIO m, MonadCatch m)
147+initStore :: (MonadIO m, MonadCatch m, Allow s)
152148 => Credentials s
153149 -> Logger
154150 -> Manager
155151 -> m (Store s)
156−initStore c l m = undefined -- exchange c l m >>= liftIO . newMVar
157−
158−-- -- | Concurrently read the current token, and if expired, then
159−-- -- safely perform a single serial refresh.
160−-- getToken :: (MonadIO m, MonadCatch m)
161−-- => Store
162−-- -> Logger
163−-- -> Manager
164−-- -> m OAuthToken
165−-- getToken s l m = do
166−-- x <- liftIO (readMVar s)
167−-- mx <- validate x
168−-- if mx
169−-- then pure (_token x)
170−-- else liftIO . modifyMVar s $ \y -> do
171−-- my <- validate y
172−-- if my
173−-- then pure (y, _token y)
174−-- else do
175−-- z <- refresh y l m
176−-- pure (z, _token z)
177−
178−-- -- | Perform the initial credentials exchange to obtain a valid 'OAuthToken'
179−-- -- suitable for authorizing requests.
180−-- exchange :: (MonadIO m, MonadCatch m)
181−-- => Credentials
182−-- -> Logger
183−-- -> Manager
184−-- -> m Auth
185−-- exchange c l = fmap (Auth c) . action l
186−-- where
187−-- action = case c of
188−-- FromMetadata s -> metadataToken s
189−-- FromAccount a ss -> serviceAccountToken a ss
190−-- FromClient c n -> exchangeCode c n
191−-- FromUser u -> authorizedUserToken u Nothing
192−
193−-- -- | Refresh an existing 'OAuthToken' using
194−-- refresh :: (MonadIO m, MonadCatch m)
195−-- => Auth
196−-- -> Logger
197−-- -> Manager
198−-- -> m Auth
199−-- refresh (Auth c t) l = fmap (Auth c) . action l
200−-- where
201−-- action = case c of
202−-- FromMetadata s -> metadataToken s
203−-- FromAccount a ss -> serviceAccountToken a ss
204−-- FromClient x _ -> refreshToken x t
205−-- FromUser u -> authorizedUserToken u (_tokenRefresh t)
206−
207−-- -- | Apply the (by way of possible token refresh) a bearer token to the
208−-- -- authentication header of a request.
209−-- authorize :: (MonadIO m, MonadCatch m)
210−-- => Client.Request
211−-- -> Store
212−-- -> Logger
213−-- -> Manager
214−-- -> m Client.Request
215−-- authorize rq s l m = bearer <$> getToken s l m
216−-- where
217−-- bearer t = rq
218−-- { Client.requestHeaders =
219−-- ( hAuthorization
220−-- , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
221−-- ) : Client.requestHeaders rq
222−-- }
152+initStore c l m = exchange c l m >>= fmap Store . liftIO . newMVar
153+
154+-- | Concurrently read the current token, and if expired, then
155+-- safely perform a single serial refresh.
156+getToken :: (MonadIO m, MonadCatch m, Allow s)
157+ => Store s
158+ -> Logger
159+ -> Manager
160+ -> m OAuthToken
161+getToken (Store s) l m = do
162+ x <- liftIO (readMVar s)
163+ mx <- validate x
164+ if mx
165+ then pure (_token x)
166+ else liftIO . modifyMVar s $ \y -> do
167+ my <- validate y
168+ if my
169+ then pure (y, _token y)
170+ else do
171+ z <- refresh y l m
172+ pure (z, _token z)
173+
174+-- | Perform the initial credentials exchange to obtain a valid 'OAuthToken'
175+-- suitable for authorizing requests.
176+exchange :: (MonadIO m, MonadCatch m, Allow s)
177+ => Credentials s
178+ -> Logger
179+ -> Manager
180+ -> m (Auth s)
181+exchange c l = fmap (Auth c) . action l
182+ where
183+ action = case c of
184+ FromMetadata s -> metadataToken s
185+ FromAccount a -> serviceAccountToken a (getScopes c)
186+ FromClient c n -> exchangeCode c n
187+ FromUser u -> authorizedUserToken u Nothing
188+
189+-- | Refresh an existing 'OAuthToken' using
190+refresh :: (MonadIO m, MonadCatch m, Allow s)
191+ => Auth s
192+ -> Logger
193+ -> Manager
194+ -> m (Auth s)
195+refresh (Auth c t) l = fmap (Auth c) . action l
196+ where
197+ action = case c of
198+ FromMetadata s -> metadataToken s
199+ FromAccount a -> serviceAccountToken a (getScopes c)
200+ FromClient x _ -> refreshToken x t
201+ FromUser u -> authorizedUserToken u (_tokenRefresh t)
202+
203+-- | Apply the (by way of possible token refresh) a bearer token to the
204+-- authentication header of a request.
205+authorize :: (MonadIO m, MonadCatch m, Allow s)
206+ => Client.Request
207+ -> Store s
208+ -> Logger
209+ -> Manager
210+ -> m Client.Request
211+authorize rq s l m = bearer <$> getToken s l m
212+ where
213+ bearer t = rq
214+ { Client.requestHeaders =
215+ ( hAuthorization
216+ , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
217+ ) : Client.requestHeaders rq
218+ }
gogol/src/Network/Google/Auth/Scope.hsnew file+126
@@ -0,0 +1,126 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE KindSignatures #-}
10+{-# LANGUAGE LambdaCase #-}
11+{-# LANGUAGE OverloadedStrings #-}
12+{-# LANGUAGE PolyKinds #-}
13+{-# LANGUAGE RecordWildCards #-}
14+{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+
19+-- |
20+-- Module : Network.Google.Auth.Scope
21+-- Copyright : (c) 2015 Brendan Hay
22+-- License : Mozilla Public License, v. 2.0.
23+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
24+-- Stability : provisional
25+-- Portability : non-portable (GHC extensions)
26+--
27+-- Explicitly specify your Google credentials, or retrieve them
28+-- from the underlying OS.
29+module Network.Google.Auth.Scope where
30+
31+import Control.Applicative
32+import Control.Concurrent
33+import Control.Exception.Lens
34+import Control.Lens hiding (coerce, (.=))
35+import Control.Monad
36+import Control.Monad.Catch
37+import Control.Monad.IO.Class
38+import Crypto.Hash.Algorithms (SHA256 (..))
39+import Crypto.PubKey.RSA.PKCS15 (signSafer)
40+import Crypto.PubKey.RSA.Types (PrivateKey)
41+import Data.Aeson
42+import Data.Aeson.Types
43+import Data.ByteArray
44+import Data.ByteArray.Encoding
45+import Data.ByteString (ByteString)
46+import Data.ByteString.Builder (Builder)
47+import qualified Data.ByteString.Builder as Build
48+import qualified Data.ByteString.Char8 as BS8
49+import qualified Data.ByteString.Lazy as LBS
50+import Data.Coerce
51+import Data.Default.Class (def)
52+import Data.List
53+import Data.String
54+import qualified Data.Text as Text
55+import qualified Data.Text.Encoding as Text
56+import Data.Time
57+import Data.Time.Clock.POSIX
58+import Data.Type.Bool
59+import Data.Type.Equality
60+import Data.Typeable
61+import Data.X509
62+import Data.X509.Memory
63+import GHC.Exts (Constraint)
64+import GHC.TypeLits
65+import Network.Google.Internal.Auth
66+import Network.Google.Internal.Logger
67+import Network.Google.Prelude
68+import Network.HTTP.Conduit hiding (Proxy)
69+import qualified Network.HTTP.Conduit as Client
70+import Network.HTTP.Types
71+
72+-- | Type-restrict the supplied credentials/whatever to the specific scopes.
73+--
74+-- This simply exists to allow users to choose between 'getCredentials' and
75+-- 'getCredentialsP' styles, without having the two separate functions.
76+--
77+-- This seems sufficiently general, does it already exist?
78+--
79+-- /See:/ '(!)'.
80+authorize :: proxy s -> k s -> k s
81+authorize _ = id
82+
83+-- | Determine if _any_ of the scopes a request requires is a subset
84+-- of the scopes the credentials supports.
85+type family Authorize (s :: [Symbol]) a :: Constraint where
86+ -- The use of 'HasScope' will show the reduced failing case,
87+ -- and the use of '∈' will give the error context.
88+ Authorize s a = HasScope (Ss a) s ∈ s
89+
90+-- | For error message/presentation purposes, this wraps the result of
91+-- the existence checks below.
92+type family (∈) p s :: Constraint where
93+ (∈) 'True s = ()
94+
95+type family HasScope a s where
96+ HasScope a (x ': xs) = Elem x a || HasScope a xs
97+
98+-- | Does 'a :: *' exist in 'b :: [*]'.
99+type family Elem a b where
100+ Elem x '[] = 'False
101+ Elem x (y ': xs) = x == y || Elem x xs
102+
103+-- | Type-level append.
104+type family (++) xs ys where
105+ (++) a '[] = a
106+ (++) '[] b = b
107+ (++) (a ': as) bs = a ': (as ++ bs)
108+
109+class Allow a where
110+ -- | Obtain a list of supported 'OAuthScope's from a proxy type.
111+ getScopes :: proxy a -> [OAuthScope]
112+
113+instance Allow '[] where
114+ getScopes _ = []
115+
116+instance (KnownSymbol x, Allow xs) => Allow (x ': xs) where
117+ getScopes _ = scope (Proxy :: Proxy x) : getScopes (Proxy :: Proxy xs)
118+ where
119+ scope = OAuthScope . Text.pack . symbolVal
120+
121+instance Allow s => Allow (Credentials s) where
122+ getScopes _ = getScopes (Proxy :: Proxy s)
123+
124+-- | Append the types of two 'Proxy' values.
125+(!) :: proxy xs -> proxy ys -> Proxy (xs ++ ys)
126+(!) _ _ = Proxy
gogol/src/Network/Google/Env.hs+56−67
@@ -3,6 +3,7 @@
33{-# LANGUAGE FunctionalDependencies #-}
44{-# LANGUAGE KindSignatures #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
6+
67-- |
78-- Module : Network.Google.Env
89-- Copyright : (c) 2015-2016 Brendan Hay
@@ -29,7 +30,7 @@ import Network.Google.Types
2930import Network.HTTP.Conduit
3031
3132-- | The environment containing the parameters required to make Google requests.
32−data Env (s :: [*]) = Env
33+data Env (s :: [Symbol]) = Env
3334 { _envOverride :: !(Dual (Endo Service))
3435 , _envLogger :: !Logger
3536 , _envManager :: !Manager
@@ -63,85 +64,73 @@ class HasEnv s a | a -> s where
6364instance HasEnv s (Env s) where
6465 environment = id
6566
66−-- -- | Provide a function which will be added to the existing stack
67−-- -- of overrides applied to all service configuration.
68−-- --
69−-- -- To override a specific service, it's suggested you use
70−-- -- either 'configure' or 'reconfigure' with a modified version of the default
71−-- -- service, such as @Network.Google.Gmail.gmailService@.
72−-- override :: HasEnv a => (Service -> Service) -> a -> a
73−-- override f = envOverride <>~ Dual (Endo f)
74−
75−-- -- | Configure a specific service. All requests belonging to the
76−-- -- supplied service will use this configuration instead of the default.
77−-- --
78−-- -- It's suggested you use a modified version of the default service, such
79−-- -- as @Network.Google.Gmail.gmailService@.
80−-- --
81−-- -- /See:/ 'reconfigure'.
82−-- configure :: HasEnv a => Service -> a -> a
83−-- configure s = override f
84−-- where
85−-- f x | on (==) _svcId s x = s
86−-- | otherwise = x
87−
88−-- -- | Scope an action such that all requests belonging to the supplied service
89−-- -- will use this configuration instead of the default.
90−-- --
91−-- -- It's suggested you use a modified version of the default service, such
92−-- -- as @Network.Google.Gmail.gmailService@.
93−-- --
94−-- -- /See:/ 'configure'.
95−-- reconfigure :: (MonadReader r m, HasEnv r) => Service -> m a -> m a
96−-- reconfigure = local . configure
97−
98−-- -- | Scope an action such that any HTTP response will use this timeout value.
99−-- --
100−-- -- Default timeouts are chosen by considering:
101−-- --
102−-- -- * This 'timeout', if set.
103−-- --
104−-- -- * The related 'Service' timeout for the sent request if set. (Usually 70s)
105−-- --
106−-- -- * The 'envManager' timeout if set.
107−-- --
108−-- -- * The default 'ClientRequest' timeout. (Approximately 30s)
109−-- timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a
110−-- timeout s = local (override (serviceTimeout ?~ s))
67+-- | Provide a function which will be added to the existing stack
68+-- of overrides applied to all service configuration.
69+--
70+-- To override a specific service, it's suggested you use
71+-- either 'configure' or 'reconfigure' with a modified version of the default
72+-- service, such as @Network.Google.Gmail.gmailService@.
73+override :: HasEnv s a => (Service -> Service) -> a -> a
74+override f = envOverride <>~ Dual (Endo f)
75+
76+-- | Configure a specific service. All requests belonging to the
77+-- supplied service will use this configuration instead of the default.
78+--
79+-- It's suggested you use a modified version of the default service, such
80+-- as @Network.Google.Gmail.gmailService@.
81+--
82+-- /See:/ 'reconfigure'.
83+configure :: HasEnv s a => Service -> a -> a
84+configure s = override f
85+ where
86+ f x | on (==) _svcId s x = s
87+ | otherwise = x
88+
89+-- | Scope an action such that all requests belonging to the supplied service
90+-- will use this configuration instead of the default.
91+--
92+-- It's suggested you use a modified version of the default service, such
93+-- as @Network.Google.Gmail.gmailService@.
94+--
95+-- /See:/ 'configure'.
96+reconfigure :: (MonadReader r m, HasEnv s r) => Service -> m a -> m a
97+reconfigure = local . configure
98+
99+-- | Scope an action such that any HTTP response will use this timeout value.
100+--
101+-- Default timeouts are chosen by considering:
102+--
103+-- * This 'timeout', if set.
104+--
105+-- * The related 'Service' timeout for the sent request if set. (Usually 70s)
106+--
107+-- * The 'envManager' timeout if set.
108+--
109+-- * The default 'ClientRequest' timeout. (Approximately 30s)
110+timeout :: (MonadReader r m, HasEnv s r) => Seconds -> m a -> m a
111+timeout s = local (override (serviceTimeout ?~ s))
111112
112113-- | Creates a new environment with a new 'Manager', without logging.
113−-- Credentials are determined by calling 'discover'. Use 'newEnvWith' to supply
114−-- custom credentials such as an 'OAuthClient' and 'OAuthCode'.
114+-- Credentials are determined by calling 'getApplicationDefault'.
115+-- Use 'newEnvWith' to supply custom credentials such as an 'OAuthClient'
116+-- and 'OAuthCode'.
115117--
116−-- The specified 'Scope's are used to authorize any @service_account@ that is
117−-- found with the appropriate scopes, otherwise they are not used. See the
118−-- top-level module of each individual @gogol-*@ library for a list of available
119−-- scopes, such as @Network.Google.Compute.computeScope@.
118+-- The 'Allow'ed 'OAuthScope's are used to authorize any @service_account@ that is
119+-- found with the appropriate scopes. See the top-level module of each individual
120+-- @gogol-*@ library for a list of available scopes, such as
121+-- @Network.Google.Compute.computeScope@.
120122--
121123-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
122124--
123125-- /See:/ 'newEnvWith', 'getApplicationDefault'.
124−newEnv :: (MonadIO m, MonadCatch m) => m (Env s)
126+newEnv :: (MonadIO m, MonadCatch m, Allow s) => m (Env s)
125127newEnv = do
126128 m <- liftIO (newManager tlsManagerSettings)
127129 c <- getApplicationDefault m
128130 newEnvWith c (\_ _ -> pure ()) m
129131
130−-- | Creates a new environment without logging, using the supplied 'Manager' and
131−-- credentials. Use either the 'Credentials' constructor or
132−-- see one of following functions from "Network.Google.Auth" for how to instantiate
133−-- a 'Credentials' value:
134−--
135−-- * 'discover' - Attempt to discover credentials from the underlying host.
136−--
137−-- * 'fromFile' - Attempt to load credentials from the well known file locations.
138−--
139−-- * 'fromFilePath' - Supply a file path to load credentials from.
140−--
141−-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
142−--
143132-- /See:/ 'newEnv'.
144−newEnvWith :: (MonadIO m, MonadCatch m)
133+newEnvWith :: (MonadIO m, MonadCatch m, Allow s)
145134 => Credentials s
146135 -> Logger
147136 -> Manager
gogol/src/Network/Google/Internal/Auth.hs+13−18
@@ -7,6 +7,11 @@
77{-# LANGUAGE KindSignatures #-}
88{-# LANGUAGE LambdaCase #-}
99{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
1015
1116-- |
1217-- Module : Network.Google.Internal.Auth
@@ -40,7 +45,9 @@ import qualified Data.ByteString.Lazy as LBS
4045import Data.Coerce
4146import Data.Default.Class (def)
4247import Data.List (intersperse)
48+import Data.Monoid
4349import Data.String
50+import Data.Text (Text)
4451import qualified Data.Text as Text
4552import qualified Data.Text.Encoding as Text
4653import qualified Data.Text.Lazy as LText
@@ -48,24 +55,22 @@ import qualified Data.Text.Lazy.Builder as TBuild
4855import qualified Data.Text.Lazy.Encoding as LText
4956import Data.Time
5057import Data.Time.Clock.POSIX
58+import Data.Type.Bool
59+import Data.Type.Equality
5160import Data.Typeable
5261import Data.X509
5362import Data.X509.Memory
63+import GHC.Exts (Constraint)
5464import GHC.TypeLits
5565import Network.Google.Compute.Metadata
5666import Network.Google.Internal.Logger
57−import Network.Google.Prelude hiding (buildText)
58−import Network.HTTP.Conduit hiding (Request)
67+import Network.Google.Prelude
68+import Network.HTTP.Conduit hiding (Proxy, Request)
5969import qualified Network.HTTP.Conduit as Client
6070import Network.HTTP.Types
61−import System.Directory (doesFileExist,
62− getHomeDirectory)
63−import System.Environment (lookupEnv)
64−import System.FilePath ((</>))
65−import System.Info (os)
6671
6772-- | The supported credential mechanisms.
68−data Credentials (s :: [*])
73+data Credentials (s :: [Symbol])
6974 = FromMetadata !ServiceId
7075 -- ^ Obtain and refresh access tokens from the underlying GCE host metadata
7176 -- at @http:\/\/169.254.169.254@.
@@ -192,16 +197,6 @@ instance FromJSON (UTCTime -> OAuthToken) where
192197 e <- o .: "expires_in" <&> fromInteger
193198 pure (OAuthToken t r . addUTCTime e)
194199
195−-- | Check if the given token is still valid, ie. younger than the projected
196−-- expiry time.
197−--
198−-- This deliberately makes no external calls due to the absolute construction of
199−-- the '_tokenExpiry' field, unlike the
200−-- <https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken documented>
201−-- validation method.
202−validate :: MonadIO m => OAuthToken -> m Bool
203−validate t = (< _tokenExpiry t) <$> liftIO getCurrentTime
204−
205200newtype OAuthCode = OAuthCode Text
206201 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
207202
gogol/src/Network/Google/Internal/HTTP.hs+4−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DataKinds #-}
12{-# LANGUAGE FlexibleContexts #-}
23{-# LANGUAGE LambdaCase #-}
34{-# LANGUAGE OverloadedStrings #-}
@@ -24,6 +25,7 @@ import qualified Data.Text.Encoding as Text
2425import qualified Data.Text.Lazy as LText
2526import qualified Data.Text.Lazy.Builder as Build
2627import GHC.Exts (toList)
28+import GHC.TypeLits
2729import Network.Google.Auth
2830import Network.Google.Env (Env (..))
2931import Network.Google.Internal.Logger
@@ -42,8 +44,8 @@ import Network.HTTP.Types
4244--
4345-- "resumable" or "multipart" needs to go into the "uploadType" param
4446
45−perform :: (MonadCatch m, MonadResource m, GoogleRequest a)
46− => Env
47+perform :: (MonadCatch m, MonadResource m, Allow s, GoogleRequest a)
48+ => Env s
4749 -> a
4850 -> m (Either Error (Rs a))
4951perform Env{..} x = catches go handlers