git.iko.soy/gogol
on develop help sign in
Adding type families and scope allow/authorize primitives
033fe2cBrendan Hay
gogol/gogol.cabal+1
compare with develop
unifiedsplit
@@ -41,6 +41,7 @@ library
41 exposed-modules:
41 exposed-modules:
42 Network.Google
42 Network.Google
43 , Network.Google.Auth
43 , Network.Google.Auth
44+ , Network.Google.Auth.Scope
44 , Network.Google.Auth.ApplicationDefault
45 , Network.Google.Auth.ApplicationDefault
45 , Network.Google.Auth.Device
46 , Network.Google.Auth.Device
46 , Network.Google.Auth.InstalledApplication
47 , Network.Google.Auth.InstalledApplication
gogol/src/Network/Google.hs+170−175
@@ -1,8 +1,10 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
@@ -24,71 +26,75 @@
24-- A 'MonadGoogle' typeclass is used as a function constraint to provide automatic
26-- A 'MonadGoogle' typeclass is used as a function constraint to provide automatic
25-- lifting of functions when embedding 'Google' as a layer inside your own
27-- lifting of functions when embedding 'Google' as a layer inside your own
26-- application stack.
28-- application stack.
27−module Network.Google where
29+module Network.Google
28− -- (
30+ (
29− -- -- * Running Google Actions
31+ -- * Running Google Actions
30− -- Google (..)
32+ Google (..)
31− -- , MonadGoogle (..)
33+ , MonadGoogle (..)
32− -- , runGoogle
34+ , runGoogle
33− -- , runResourceT
35+ , runResourceT
34
36
35− -- -- * Authentication and Environment
37+ -- * Authentication and Environment
36− -- , newEnv
37− -- , Env
38+ , Env
38− -- , HasEnv (..)
39+ , HasEnv (..)
40+ , newEnv
39
41
40− -- -- * Sending Requests
42+ -- ** Customized Environment
41− -- , send
43+ , newEnvWith
44+ , getApplicationDefault
42
45
43− -- -- ** Media Downloads
46+ -- * Sending Requests
44− -- , download
47+ , send
45
48
46− -- -- ** Media Uploads
49+ -- ** Media Downloads
47− -- , upload
50+ , download
48
51
49− -- , ToBody (..)
52+ -- ** Media Uploads
50− -- , RequestBody
53+ , upload
51− -- , sourceBody
52
54
53− -- -- ** Service Configuration
55+ , ToBody (..)
54− -- -- ** Overriding Defaults
56+ , RequestBody
55− -- , configure
57+ , sourceBody
56− -- , override
57
58
58− -- -- *** Scoped Actions
59+ -- ** Service Configuration
59− -- , reconfigure
60+ -- ** Overriding Defaults
60− -- , timeout
61+ , configure
62+ , override
61
63
62− -- -- * Running Asynchronous Actions
64+ -- *** Scoped Actions
63− -- -- $async
65+ , reconfigure
66+ , timeout
64
67
65− -- -- * Handling Errors
68+ -- * Running Asynchronous Actions
66− -- , AsError (..)
69+ -- $async
67− -- , AsAuthError (..)
68
70
69− -- , trying
71+ -- * Handling Errors
70− -- , catching
72+ , AsError (..)
73+ , AsAuthError (..)
71
74
72− -- -- * Logging
75+ , trying
73− -- -- $logging
76+ , catching
74
77
75− -- , Logger
78+ -- * Logging
76− -- , LogLevel (..)
79+ -- $logging
77
80
78− -- -- ** Constructing a Logger
81+ , Logger
79− -- , newLogger
82+ , LogLevel (..)
80
83
81− -- -- * Constructing a HTTP Manager
84+ -- ** Constructing a Logger
82− -- , newManager
85+ , newLogger
83− -- , tlsManagerSettings
84
86
87+ -- * Constructing a HTTP Manager
88+ , newManager
89+ , tlsManagerSettings
90+
85− -- -- * Re-exported Types
91+ -- * Re-exported Types
86− -- , Proxy (..)
92+ , Proxy (..)
87− -- , OctetStream
93+ , OctetStream
88− -- , PlainText
94+ , PlainText
89− -- , JSON
95+ , JSON
90− -- , module Network.Google.Types
96+ , module Network.Google.Types
91− -- ) where
97+ ) where
92
98
93import Control.Applicative
99import Control.Applicative
94import Control.Exception.Lens
100import Control.Exception.Lens
@@ -129,131 +135,120 @@ newtype Google s a = Google { unGoogle :: ReaderT (Env s) (ResourceT IO) a }
129 , MonadCatch
135 , MonadCatch
130 , MonadMask
136 , MonadMask
131 , MonadBase IO
137 , MonadBase IO
132−-- , MonadReader (Env s)
138+ , MonadReader (Env s)
133 , MonadResource
139 , MonadResource
134 )
140 )
135
141
136−-- | Run a 'Google' aciton using the specified environment.
142+-- | Run a 'Google' aciton using the specified environment containing
143+-- credentials with sufficient authorization scopes.
137−-- runGoogle :: (MonadResource m, HasEnv s r) => r -> Google s a -> m a
144+runGoogle :: (MonadResource m, HasEnv s r) => r -> Google s a -> m a
138−-- runGoogle e m = liftResourceT $ runReaderT (unGoogle m) (e ^. environment)
145+runGoogle e m = liftResourceT $ runReaderT (unGoogle m) (e ^. environment)
139−
146+
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.
147+-- | Monads in which 'Google' actions may be embedded.
148+class ( Allow s
175−-- class ( Functor m
149+ , Functor m
176−-- , Applicative m
150+ , Applicative m
177−-- , Monad m
151+ , Monad m
178−-- , MonadIO m
152+ , MonadIO m
179−-- , MonadCatch m
153+ , MonadCatch m
180−-- ) => MonadGoogle m where
154+ ) => MonadGoogle s m | m -> s where
181−-- -- | Lift a computation to the 'Google' monad.
155+ -- | Lift a computation to the 'Google' monad.
182−-- liftGoogle :: Google a -> m a
156+ liftGoogle :: Google s a -> m a
183−
157+
184−-- instance MonadGoogle Google where
158+instance Allow s => MonadGoogle s (Google s) where
185−-- liftGoogle = id
159+ liftGoogle = id
186−
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+
187−-- instance MonadGoogle m => MonadGoogle (IdentityT m) where liftGoogle = lift . liftGoogle
167+instance MonadGoogle s m => MonadGoogle s (IdentityT m) where
168+ liftGoogle = lift . liftGoogle
169+
188−-- instance MonadGoogle m => MonadGoogle (ListT m) where liftGoogle = lift . liftGoogle
170+instance MonadGoogle s m => MonadGoogle s (ListT m) where
171+ liftGoogle = lift . liftGoogle
172+
189−-- instance MonadGoogle m => MonadGoogle (MaybeT m) where liftGoogle = lift . liftGoogle
173+instance MonadGoogle s m => MonadGoogle s (MaybeT m) where
174+ liftGoogle = lift . liftGoogle
175+
190−-- instance MonadGoogle m => MonadGoogle (ExceptT e m) where liftGoogle = lift . liftGoogle
176+instance MonadGoogle s m => MonadGoogle s (ExceptT e m) where
177+ liftGoogle = lift . liftGoogle
178+
191−-- instance MonadGoogle m => MonadGoogle (ReaderT r m) where liftGoogle = lift . liftGoogle
179+instance MonadGoogle s m => MonadGoogle s (ReaderT r m) where
180+ liftGoogle = lift . liftGoogle
181+
192−-- instance MonadGoogle m => MonadGoogle (S.StateT s m) where liftGoogle = lift . liftGoogle
182+instance MonadGoogle s m => MonadGoogle s (S.StateT s' m) where
183+ liftGoogle = lift . liftGoogle
184+
193−-- instance MonadGoogle m => MonadGoogle (LS.StateT s m) where liftGoogle = lift . liftGoogle
185+instance MonadGoogle s m => MonadGoogle s (LS.StateT s' m) where
194−
186+ liftGoogle = lift . liftGoogle
187+
195−-- instance (Monoid w, MonadGoogle m) => MonadGoogle (W.WriterT w m) where
188+instance (Monoid w, MonadGoogle s m) => MonadGoogle s (W.WriterT w m) where
196−-- liftGoogle = lift . liftGoogle
189+ liftGoogle = lift . liftGoogle
197−
190+
198−-- instance (Monoid w, MonadGoogle m) => MonadGoogle (LW.WriterT w m) where
191+instance (Monoid w, MonadGoogle s m) => MonadGoogle s (LW.WriterT w m) where
199−-- liftGoogle = lift . liftGoogle
192+ liftGoogle = lift . liftGoogle
200−
193+
201−-- instance (Monoid w, MonadGoogle m) => MonadGoogle (RW.RWST r w s m) where
194+instance (Monoid w, MonadGoogle s m) => MonadGoogle s (RW.RWST r w s' m) where
202−-- liftGoogle = lift . liftGoogle
195+ liftGoogle = lift . liftGoogle
203−
196+
204−-- instance (Monoid w, MonadGoogle m) => MonadGoogle (LRW.RWST r w s m) where
197+instance (Monoid w, MonadGoogle s m) => MonadGoogle s (LRW.RWST r w s' m) where
205−-- liftGoogle = lift . liftGoogle
198+ liftGoogle = lift . liftGoogle
206−
199+
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.
200+-- | Send a request, returning the associated response if successful.
212−-- --
201+--
213−-- -- Throws 'Error'.
202+-- Throws 'Error'.
214−-- send :: (MonadGoogle m, GoogleRequest a) => a -> m (Rs a)
203+send :: (MonadGoogle s m, Authorize s a, GoogleRequest a) => a -> m (Rs a)
215−-- send x = liftGoogle $ do
204+send x = liftGoogle $ do
216−-- e <- ask
205+ e <- ask
217−-- r <- perform e x
206+ r <- perform e x
218−-- hoistError r
207+ hoistError r
219−
208+
220−-- -- | Send a request returning the associated streaming media response if successful.
209+-- | Send a request returning the associated streaming media response if successful.
221−-- --
210+--
222−-- -- Some request data types have two possible responses, the JSON metadata and
211+-- 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'
212+-- a streaming media response. Use 'send' to retrieve the metadata and 'download'
224−-- -- to retrieve the streaming media.
213+-- to retrieve the streaming media.
225−-- --
214+--
226−-- -- Throws 'Error'.
215+-- Throws 'Error'.
216+download :: ( MonadGoogle s m
217+ , Authorize s (MediaDownload a)
227−-- download :: (MonadGoogle m, GoogleRequest (MediaDownload a))
218+ , GoogleRequest (MediaDownload a)
219+ )
228−-- => a
220+ => a
229−-- -> m (Rs (MediaDownload a))
221+ -> m (Rs (MediaDownload a))
230−-- download = send . MediaDownload
222+download = send . MediaDownload
231−
223+
232−-- -- | Send a request with an attached multipart/related media upload.
224+-- | Send a request with an attached multipart/related media upload.
233−-- --
225+--
234−-- -- Throws 'Error'.
226+-- Throws 'Error'.
227+upload :: ( MonadGoogle s m
228+ , Authorize s (MediaUpload a)
235−-- upload :: (MonadGoogle m, GoogleRequest (MediaUpload a))
229+ , GoogleRequest (MediaUpload a)
230+ )
236−-- => a
231+ => a
237−-- -> RequestBody
232+ -> RequestBody
238−-- -> m (Rs (MediaUpload a))
233+ -> m (Rs (MediaUpload a))
239−-- upload x = send . MediaUpload x
234+upload x = send . MediaUpload x
240−
235+
241−-- hoistError :: MonadThrow m => Either Error a -> m a
236+hoistError :: MonadThrow m => Either Error a -> m a
242−-- hoistError = either (throwingM _Error) return
237+hoistError = either (throwingM _Error) return
243−
238+
244−-- {- $async
239+{- $async
245−-- Requests can be sent asynchronously, but due to guarantees about resource closure
240+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>.
241+require the use of <http://hackage.haskell.org/package/lifted-async lifted-async>.
247−-- -}
242+-}
248−
243+
249−-- {- $logging
244+{- $logging
250−-- The exposed logging interface is a primitive 'Logger' function which gets
245+The exposed logging interface is a primitive 'Logger' function which gets
251−-- threaded through service calls and serialisation routines. This allows the
246+threaded through service calls and serialisation routines. This allows the
252−-- library to output useful information and diagnostics.
247+library to output useful information and diagnostics.
253−
248+
254−-- The 'newLogger' function can be used to construct a simple logger which writes
249+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
250+output to a 'Handle', but in most production code you should probably consider
256−-- using a more robust logging library such as
251+using a more robust logging library such as
257−-- <http://hackage.haskell.org/package/tiny-log tiny-log> or
252+<http://hackage.haskell.org/package/tiny-log tiny-log> or
258−-- <http://hackage.haskell.org/package/fast-logger fast-logger>.
253+<http://hackage.haskell.org/package/fast-logger fast-logger>.
259−-- -}
254+-}
gogol/src/Network/Google/Auth.hs+133−137
@@ -1,5 +1,4 @@
1{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE UndecidableInstances #-}
3{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
@@ -15,6 +14,7 @@
15{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE UndecidableInstances #-}
18
18
19-- |
19-- |
20-- Module : Network.Google.Auth
20-- Module : Network.Google.Auth
@@ -26,52 +26,55 @@
26--
26--
27-- Explicitly specify your Google credentials, or retrieve them
27-- Explicitly specify your Google credentials, or retrieve them
28-- from the underlying OS.
28-- from the underlying OS.
29−module Network.Google.Auth where
29+module Network.Google.Auth
30− -- (
30+ (
31− -- -- * Credentials
31+ -- * Credentials
32− -- Credentials (..)
32+ Credentials (..)
33−
33+
34− -- -- ** Application Default Credentials
34+ -- ** Application Default Credentials
35− -- , getApplicationDefault
35+ , getApplicationDefault
36− -- , fromWellKnownPath
36+ , fromWellKnownPath
37− -- , fromFilePath
37+ , fromFilePath
38−
38+
39− -- -- ** Installed Application Credentials
39+ -- ** Installed Application Credentials
40− -- , formURL
40+ , formURL
41−
41+
42− -- -- ** Authorizing Requests
42+ -- ** Authorizing Requests
43− -- , authorize
43+ , authorize
44−
44+
45− -- -- ** Thread-safe Storage
45+ -- ** Thread-safe Storage
46− -- , Store
46+ , Store
47− -- , initStore
47+ , initStore
48−
48+
49− -- , Auth (..)
49+ , Auth (..)
50− -- , exchange
50+ , exchange
51− -- , refresh
51+ , refresh
52−
52+
53− -- -- ** Default Constants
53+ -- ** Default Constants
54− -- , checkGCEVar
54+ , checkGCEVar
55− -- , cloudSDKConfigDir
55+ , cloudSDKConfigDir
56− -- , defaultCredentialsFile
56+ , defaultCredentialsFile
57−
57+
58− -- -- ** Handling Errors
58+ -- ** Handling Errors
59− -- , AsAuthError (..)
59+ , AsAuthError (..)
60− -- , AuthError (..)
60+ , AuthError (..)
61−
61+
62− -- -- * OAuth Types
62+ -- * OAuth Types
63− -- , OAuthClient (..)
63+ , OAuthClient (..)
64− -- , OAuthToken (..)
64+ , OAuthToken (..)
65− -- , OAuthCode (..)
65+ , OAuthCode (..)
66− -- , OAuthScope (..)
66+ , OAuthScope (..)
67−
67+
68− -- -- * Re-exported Types
68+ -- * Re-exported Types
69− -- , AccessToken (..)
69+ , AccessToken (..)
70− -- , RefreshToken (..)
70+ , RefreshToken (..)
71− -- , Secret (..)
71+ , Secret (..)
72− -- , ServiceId (..)
72+ , ServiceId (..)
73− -- , ClientId (..)
73+ , ClientId (..)
74+
75+ -- * Re-exported Modules
76+ , module Network.Google.Auth.Scope
74− -- ) where
77+ ) where
75
78
76import Control.Applicative
79import Control.Applicative
77import Control.Concurrent
80import Control.Concurrent
@@ -100,14 +103,17 @@ import qualified Data.Text as Text
100import qualified Data.Text.Encoding as Text
103import qualified Data.Text.Encoding as Text
101import Data.Time
104import Data.Time
102import Data.Time.Clock.POSIX
105import Data.Time.Clock.POSIX
106+import Data.Type.Bool
107+import Data.Type.Equality
103import Data.Typeable
108import Data.Typeable
104import Data.X509
109import Data.X509
105import Data.X509.Memory
110import Data.X509.Memory
106import GHC.Exts (Constraint)
111import GHC.Exts (Constraint)
107−import GHC.TypeLits
112+import GHC.TypeLits
108import Network.Google.Auth.ApplicationDefault
113import Network.Google.Auth.ApplicationDefault
109import Network.Google.Auth.Device
114import Network.Google.Auth.Device
110import Network.Google.Auth.InstalledApplication
115import Network.Google.Auth.InstalledApplication
116+import Network.Google.Auth.Scope
111import Network.Google.Auth.ServiceAccount
117import Network.Google.Auth.ServiceAccount
112import Network.Google.Compute.Metadata
118import Network.Google.Compute.Metadata
113import Network.Google.Internal.Auth
119import Network.Google.Internal.Auth
@@ -117,106 +123,96 @@ import Network.HTTP.Conduit hiding (Proxy)
117import qualified Network.HTTP.Conduit as Client
123import qualified Network.HTTP.Conduit as Client
118import Network.HTTP.Types
124import Network.HTTP.Types
119
125
120−
121-- | An 'OAuthToken' that can potentially be expired, with the original
126-- | An 'OAuthToken' that can potentially be expired, with the original
122-- credentials that can be used to perform a refresh.
127-- credentials that can be used to perform a refresh.
123−data Auth (s :: [*]) = Auth
128+data Auth (s :: [Symbol]) = Auth
124 { _credentials :: !(Credentials s)
129 { _credentials :: !(Credentials s)
125 , _token :: !OAuthToken
130 , _token :: !OAuthToken
126 }
131 }
127
132
128−newtype Store (s :: [*]) = Store { store :: MVar (Auth s) }
133+-- | Check if the given token is still valid, ie. younger than the projected
129−
134+-- expiry time.
130−-- type family HasScope s a :: Constraint where
135+--
131−-- HasScope s a = IsSubList s (Ss a)
136+-- This deliberately makes no external calls due to the absolute construction of
132−
137+-- the '_tokenExpiry' field, unlike the
133−type family And (a :: Constraint) (b :: Constraint) :: Constraint where
138+-- <https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken documented>
134− And () () = ()
139+-- validation method.
135−
140+validate :: MonadIO m => Auth s -> m Bool
136−type family IsSubList a b :: Constraint where
141+validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime
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
141
142
142−-- authorize :: (MonadIO m, MonadCatch m)
143+newtype Store (s :: [Symbol]) = Store (MVar (Auth s))
143−-- => Credentials s
144−-- -> Logger
145−-- -> Manager
146−-- -> m (Store s)
147−-- authorize = undefined
148
144
149-- | Construct storage containing the credentials which have not yet been
145-- | Construct storage containing the credentials which have not yet been
150-- exchanged or refreshed.
146-- exchanged or refreshed.
151−initStore :: (MonadIO m, MonadCatch m)
147+initStore :: (MonadIO m, MonadCatch m, Allow s)
152 => Credentials s
148 => Credentials s
153 -> Logger
149 -> Logger
154 -> Manager
150 -> Manager
155 -> m (Store s)
151 -> m (Store s)
156−initStore c l m = undefined -- exchange c l m >>= liftIO . newMVar
152+initStore c l m = exchange c l m >>= fmap Store . liftIO . newMVar
157−
153+
158−-- -- | Concurrently read the current token, and if expired, then
154+-- | Concurrently read the current token, and if expired, then
159−-- -- safely perform a single serial refresh.
155+-- safely perform a single serial refresh.
160−-- getToken :: (MonadIO m, MonadCatch m)
156+getToken :: (MonadIO m, MonadCatch m, Allow s)
161−-- => Store
157+ => Store s
162−-- -> Logger
158+ -> Logger
163−-- -> Manager
159+ -> Manager
164−-- -> m OAuthToken
160+ -> m OAuthToken
165−-- getToken s l m = do
161+getToken (Store s) l m = do
166−-- x <- liftIO (readMVar s)
162+ x <- liftIO (readMVar s)
167−-- mx <- validate x
163+ mx <- validate x
168−-- if mx
164+ if mx
169−-- then pure (_token x)
165+ then pure (_token x)
170−-- else liftIO . modifyMVar s $ \y -> do
166+ else liftIO . modifyMVar s $ \y -> do
171−-- my <- validate y
167+ my <- validate y
172−-- if my
168+ if my
173−-- then pure (y, _token y)
169+ then pure (y, _token y)
174−-- else do
170+ else do
175−-- z <- refresh y l m
171+ z <- refresh y l m
176−-- pure (z, _token z)
172+ pure (z, _token z)
177−
173+
178−-- -- | Perform the initial credentials exchange to obtain a valid 'OAuthToken'
174+-- | Perform the initial credentials exchange to obtain a valid 'OAuthToken'
179−-- -- suitable for authorizing requests.
175+-- suitable for authorizing requests.
180−-- exchange :: (MonadIO m, MonadCatch m)
176+exchange :: (MonadIO m, MonadCatch m, Allow s)
181−-- => Credentials
177+ => Credentials s
182−-- -> Logger
178+ -> Logger
183−-- -> Manager
179+ -> Manager
184−-- -> m Auth
180+ -> m (Auth s)
185−-- exchange c l = fmap (Auth c) . action l
181+exchange c l = fmap (Auth c) . action l
186−-- where
182+ where
187−-- action = case c of
183+ action = case c of
188−-- FromMetadata s -> metadataToken s
184+ FromMetadata s -> metadataToken s
189−-- FromAccount a ss -> serviceAccountToken a ss
185+ FromAccount a -> serviceAccountToken a (getScopes c)
190−-- FromClient c n -> exchangeCode c n
186+ FromClient c n -> exchangeCode c n
191−-- FromUser u -> authorizedUserToken u Nothing
187+ FromUser u -> authorizedUserToken u Nothing
192−
188+
193−-- -- | Refresh an existing 'OAuthToken' using
189+-- | Refresh an existing 'OAuthToken' using
194−-- refresh :: (MonadIO m, MonadCatch m)
190+refresh :: (MonadIO m, MonadCatch m, Allow s)
195−-- => Auth
191+ => Auth s
196−-- -> Logger
192+ -> Logger
197−-- -> Manager
193+ -> Manager
198−-- -> m Auth
194+ -> m (Auth s)
199−-- refresh (Auth c t) l = fmap (Auth c) . action l
195+refresh (Auth c t) l = fmap (Auth c) . action l
200−-- where
196+ where
201−-- action = case c of
197+ action = case c of
202−-- FromMetadata s -> metadataToken s
198+ FromMetadata s -> metadataToken s
203−-- FromAccount a ss -> serviceAccountToken a ss
199+ FromAccount a -> serviceAccountToken a (getScopes c)
204−-- FromClient x _ -> refreshToken x t
200+ FromClient x _ -> refreshToken x t
205−-- FromUser u -> authorizedUserToken u (_tokenRefresh t)
201+ FromUser u -> authorizedUserToken u (_tokenRefresh t)
206−
202+
207−-- -- | Apply the (by way of possible token refresh) a bearer token to the
203+-- | Apply the (by way of possible token refresh) a bearer token to the
208−-- -- authentication header of a request.
204+-- authentication header of a request.
209−-- authorize :: (MonadIO m, MonadCatch m)
205+authorize :: (MonadIO m, MonadCatch m, Allow s)
210−-- => Client.Request
206+ => Client.Request
211−-- -> Store
207+ -> Store s
212−-- -> Logger
208+ -> Logger
213−-- -> Manager
209+ -> Manager
214−-- -> m Client.Request
210+ -> m Client.Request
215−-- authorize rq s l m = bearer <$> getToken s l m
211+authorize rq s l m = bearer <$> getToken s l m
216−-- where
212+ where
217−-- bearer t = rq
213+ bearer t = rq
218−-- { Client.requestHeaders =
214+ { Client.requestHeaders =
219−-- ( hAuthorization
215+ ( hAuthorization
220−-- , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
216+ , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
221−-- ) : Client.requestHeaders rq
217+ ) : Client.requestHeaders rq
222−-- }
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 @@
3{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6+
6-- |
7-- |
7-- Module : Network.Google.Env
8-- Module : Network.Google.Env
8-- Copyright : (c) 2015-2016 Brendan Hay
9-- Copyright : (c) 2015-2016 Brendan Hay
@@ -29,7 +30,7 @@ import Network.Google.Types
29import Network.HTTP.Conduit
30import Network.HTTP.Conduit
30
31
31-- | The environment containing the parameters required to make Google requests.
32-- | The environment containing the parameters required to make Google requests.
32−data Env (s :: [*]) = Env
33+data Env (s :: [Symbol]) = Env
33 { _envOverride :: !(Dual (Endo Service))
34 { _envOverride :: !(Dual (Endo Service))
34 , _envLogger :: !Logger
35 , _envLogger :: !Logger
35 , _envManager :: !Manager
36 , _envManager :: !Manager
@@ -63,85 +64,73 @@ class HasEnv s a | a -> s where
63instance HasEnv s (Env s) where
64instance HasEnv s (Env s) where
64 environment = id
65 environment = id
65
66
66−-- -- | Provide a function which will be added to the existing stack
67+-- | Provide a function which will be added to the existing stack
67−-- -- of overrides applied to all service configuration.
68+-- of overrides applied to all service configuration.
68−-- --
69+--
69−-- -- To override a specific service, it's suggested you use
70+-- To override a specific service, it's suggested you use
70−-- -- either 'configure' or 'reconfigure' with a modified version of the default
71+-- either 'configure' or 'reconfigure' with a modified version of the default
71−-- -- service, such as @Network.Google.Gmail.gmailService@.
72+-- service, such as @Network.Google.Gmail.gmailService@.
72−-- override :: HasEnv a => (Service -> Service) -> a -> a
73+override :: HasEnv s a => (Service -> Service) -> a -> a
73−-- override f = envOverride <>~ Dual (Endo f)
74+override f = envOverride <>~ Dual (Endo f)
74−
75+
75−-- -- | Configure a specific service. All requests belonging to the
76+-- | Configure a specific service. All requests belonging to the
76−-- -- supplied service will use this configuration instead of the default.
77+-- supplied service will use this configuration instead of the default.
77−-- --
78+--
78−-- -- It's suggested you use a modified version of the default service, such
79+-- It's suggested you use a modified version of the default service, such
79−-- -- as @Network.Google.Gmail.gmailService@.
80+-- as @Network.Google.Gmail.gmailService@.
80−-- --
81+--
81−-- -- /See:/ 'reconfigure'.
82+-- /See:/ 'reconfigure'.
82−-- configure :: HasEnv a => Service -> a -> a
83+configure :: HasEnv s a => Service -> a -> a
83−-- configure s = override f
84+configure s = override f
84−-- where
85+ where
85−-- f x | on (==) _svcId s x = s
86+ f x | on (==) _svcId s x = s
86−-- | otherwise = x
87+ | otherwise = x
87−
88+
88−-- -- | Scope an action such that all requests belonging to the supplied service
89+-- | Scope an action such that all requests belonging to the supplied service
89−-- -- will use this configuration instead of the default.
90+-- will use this configuration instead of the default.
90−-- --
91+--
91−-- -- It's suggested you use a modified version of the default service, such
92+-- It's suggested you use a modified version of the default service, such
92−-- -- as @Network.Google.Gmail.gmailService@.
93+-- as @Network.Google.Gmail.gmailService@.
93−-- --
94+--
94−-- -- /See:/ 'configure'.
95+-- /See:/ 'configure'.
95−-- reconfigure :: (MonadReader r m, HasEnv r) => Service -> m a -> m a
96+reconfigure :: (MonadReader r m, HasEnv s r) => Service -> m a -> m a
96−-- reconfigure = local . configure
97+reconfigure = local . configure
97−
98+
98−-- -- | Scope an action such that any HTTP response will use this timeout value.
99+-- | Scope an action such that any HTTP response will use this timeout value.
99−-- --
100+--
100−-- -- Default timeouts are chosen by considering:
101+-- Default timeouts are chosen by considering:
101−-- --
102+--
102−-- -- * This 'timeout', if set.
103+-- * This 'timeout', if set.
103−-- --
104+--
104−-- -- * The related 'Service' timeout for the sent request if set. (Usually 70s)
105+-- * The related 'Service' timeout for the sent request if set. (Usually 70s)
105−-- --
106+--
106−-- -- * The 'envManager' timeout if set.
107+-- * The 'envManager' timeout if set.
107−-- --
108+--
108−-- -- * The default 'ClientRequest' timeout. (Approximately 30s)
109+-- * The default 'ClientRequest' timeout. (Approximately 30s)
109−-- timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a
110+timeout :: (MonadReader r m, HasEnv s r) => Seconds -> m a -> m a
110−-- timeout s = local (override (serviceTimeout ?~ s))
111+timeout s = local (override (serviceTimeout ?~ s))
111
112
112-- | Creates a new environment with a new 'Manager', without logging.
113-- | Creates a new environment with a new 'Manager', without logging.
113−-- Credentials are determined by calling 'discover'. Use 'newEnvWith' to supply
114+-- Credentials are determined by calling 'getApplicationDefault'.
114−-- custom credentials such as an 'OAuthClient' and 'OAuthCode'.
115+-- Use 'newEnvWith' to supply custom credentials such as an 'OAuthClient'
116+-- and 'OAuthCode'.
115--
117--
116−-- The specified 'Scope's are used to authorize any @service_account@ that is
118+-- The 'Allow'ed 'OAuthScope's are used to authorize any @service_account@ that is
117−-- found with the appropriate scopes, otherwise they are not used. See the
119+-- found with the appropriate scopes. See the top-level module of each individual
118−-- top-level module of each individual @gogol-*@ library for a list of available
120+-- @gogol-*@ library for a list of available scopes, such as
119−-- scopes, such as @Network.Google.Compute.computeScope@.
121+-- @Network.Google.Compute.computeScope@.
120--
122--
121-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
123-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
122--
124--
123-- /See:/ 'newEnvWith', 'getApplicationDefault'.
125-- /See:/ 'newEnvWith', 'getApplicationDefault'.
124−newEnv :: (MonadIO m, MonadCatch m) => m (Env s)
126+newEnv :: (MonadIO m, MonadCatch m, Allow s) => m (Env s)
125newEnv = do
127newEnv = do
126 m <- liftIO (newManager tlsManagerSettings)
128 m <- liftIO (newManager tlsManagerSettings)
127 c <- getApplicationDefault m
129 c <- getApplicationDefault m
128 newEnvWith c (\_ _ -> pure ()) m
130 newEnvWith c (\_ _ -> pure ()) m
129
131
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−--
143-- /See:/ 'newEnv'.
132-- /See:/ 'newEnv'.
144−newEnvWith :: (MonadIO m, MonadCatch m)
133+newEnvWith :: (MonadIO m, MonadCatch m, Allow s)
145 => Credentials s
134 => Credentials s
146 -> Logger
135 -> Logger
147 -> Manager
136 -> Manager
gogol/src/Network/Google/Internal/Auth.hs+13−18
@@ -7,6 +7,11 @@
7{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE KindSignatures #-}
8{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
10
15
11-- |
16-- |
12-- Module : Network.Google.Internal.Auth
17-- Module : Network.Google.Internal.Auth
@@ -40,7 +45,9 @@ import qualified Data.ByteString.Lazy as LBS
40import Data.Coerce
45import Data.Coerce
41import Data.Default.Class (def)
46import Data.Default.Class (def)
42import Data.List (intersperse)
47import Data.List (intersperse)
48+import Data.Monoid
43import Data.String
49import Data.String
50+import Data.Text (Text)
44import qualified Data.Text as Text
51import qualified Data.Text as Text
45import qualified Data.Text.Encoding as Text
52import qualified Data.Text.Encoding as Text
46import qualified Data.Text.Lazy as LText
53import qualified Data.Text.Lazy as LText
@@ -48,24 +55,22 @@ import qualified Data.Text.Lazy.Builder as TBuild
48import qualified Data.Text.Lazy.Encoding as LText
55import qualified Data.Text.Lazy.Encoding as LText
49import Data.Time
56import Data.Time
50import Data.Time.Clock.POSIX
57import Data.Time.Clock.POSIX
58+import Data.Type.Bool
59+import Data.Type.Equality
51import Data.Typeable
60import Data.Typeable
52import Data.X509
61import Data.X509
53import Data.X509.Memory
62import Data.X509.Memory
63+import GHC.Exts (Constraint)
54import GHC.TypeLits
64import GHC.TypeLits
55import Network.Google.Compute.Metadata
65import Network.Google.Compute.Metadata
56import Network.Google.Internal.Logger
66import Network.Google.Internal.Logger
57−import Network.Google.Prelude hiding (buildText)
67+import Network.Google.Prelude
58−import Network.HTTP.Conduit hiding (Request)
68+import Network.HTTP.Conduit hiding (Proxy, Request)
59import qualified Network.HTTP.Conduit as Client
69import qualified Network.HTTP.Conduit as Client
60import Network.HTTP.Types
70import Network.HTTP.Types
61−import System.Directory (doesFileExist,
62− getHomeDirectory)
63−import System.Environment (lookupEnv)
64−import System.FilePath ((</>))
65−import System.Info (os)
66
71
67-- | The supported credential mechanisms.
72-- | The supported credential mechanisms.
68−data Credentials (s :: [*])
73+data Credentials (s :: [Symbol])
69 = FromMetadata !ServiceId
74 = FromMetadata !ServiceId
70 -- ^ Obtain and refresh access tokens from the underlying GCE host metadata
75 -- ^ Obtain and refresh access tokens from the underlying GCE host metadata
71 -- at @http:\/\/169.254.169.254@.
76 -- at @http:\/\/169.254.169.254@.
@@ -192,16 +197,6 @@ instance FromJSON (UTCTime -> OAuthToken) where
192 e <- o .: "expires_in" <&> fromInteger
197 e <- o .: "expires_in" <&> fromInteger
193 pure (OAuthToken t r . addUTCTime e)
198 pure (OAuthToken t r . addUTCTime e)
194
199
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−
205newtype OAuthCode = OAuthCode Text
200newtype OAuthCode = OAuthCode Text
206 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
201 deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON)
207
202
gogol/src/Network/Google/Internal/HTTP.hs+4−2
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
@@ -24,6 +25,7 @@ import qualified Data.Text.Encoding as Text
24import qualified Data.Text.Lazy as LText
25import qualified Data.Text.Lazy as LText
25import qualified Data.Text.Lazy.Builder as Build
26import qualified Data.Text.Lazy.Builder as Build
26import GHC.Exts (toList)
27import GHC.Exts (toList)
28+import GHC.TypeLits
27import Network.Google.Auth
29import Network.Google.Auth
28import Network.Google.Env (Env (..))
30import Network.Google.Env (Env (..))
29import Network.Google.Internal.Logger
31import Network.Google.Internal.Logger
@@ -42,8 +44,8 @@ import Network.HTTP.Types
42--
44--
43-- "resumable" or "multipart" needs to go into the "uploadType" param
45-- "resumable" or "multipart" needs to go into the "uploadType" param
44
46
45−perform :: (MonadCatch m, MonadResource m, GoogleRequest a)
47+perform :: (MonadCatch m, MonadResource m, Allow s, GoogleRequest a)
46− => Env
48+ => Env s
47 -> a
49 -> a
48 -> m (Either Error (Rs a))
50 -> m (Either Error (Rs a))
49perform Env{..} x = catches go handlers
51perform Env{..} x = catches go handlers