@@ -1,11 +1,20 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE UndecidableInstances #-}
3+{-# LANGUAGE DataKinds #-}
14{-# LANGUAGE DeriveDataTypeable #-}
25{-# LANGUAGE DeriveGeneric #-}
36{-# LANGUAGE FlexibleContexts #-}
47{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE FunctionalDependencies #-}
59{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+{-# LANGUAGE KindSignatures #-}
611{-# LANGUAGE LambdaCase #-}
712{-# LANGUAGE OverloadedStrings #-}
13+{-# LANGUAGE PolyKinds #-}
814{-# LANGUAGE RecordWildCards #-}
15+{-# LANGUAGE ScopedTypeVariables #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE TypeOperators #-}
918
1019-- |
1120-- Module : Network.Google.Auth
@@ -17,86 +26,86 @@
1726--
1827-- Explicitly specify your Google credentials, or retrieve them
1928-- from the underlying OS.
20−module Network.Google.Auth
21− (
22− -- * Credentials
23− Credentials (..)
24−
25− -- ** Application Default Credentials
26− , getApplicationDefault
27− , fromWellKnownPath
28− , fromFilePath
29−
30− -- ** Installed Application Credentials
31− , formURL
32−
33− -- ** Authorizing Requests
34− , authorize
35−
36− -- ** Thread-safe Storage
37− , Store
38− , initStore
39−
40− , Auth (..)
41− , exchange
42− , refresh
43−
44− -- ** Default Constants
45− , checkGCEVar
46− , cloudSDKConfigDir
47− , defaultCredentialsFile
48−
49− -- ** Handling Errors
50− , AsAuthError (..)
51− , AuthError (..)
52−
53− -- * OAuth Types
54− , OAuthClient (..)
55− , OAuthToken (..)
56− , OAuthCode (..)
57− , OAuthScope (..)
58−
59− -- * Re-exported Types
60− , AccessToken (..)
61− , RefreshToken (..)
62− , Secret (..)
63− , ServiceId (..)
64− , ClientId (..)
65− ) where
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
6675
6776import Control.Applicative
6877import Control.Concurrent
6978import Control.Exception.Lens
70−import Control.Lens hiding
71− (coerce,
72− (.=))
79+import Control.Lens hiding (coerce, (.=))
7380import Control.Monad
7481import Control.Monad.Catch
7582import Control.Monad.IO.Class
76−import Crypto.Hash.Algorithms (SHA256 (..))
77−import Crypto.PubKey.RSA.PKCS15 (signSafer)
78−import Crypto.PubKey.RSA.Types (PrivateKey)
83+import Crypto.Hash.Algorithms (SHA256 (..))
84+import Crypto.PubKey.RSA.PKCS15 (signSafer)
85+import Crypto.PubKey.RSA.Types (PrivateKey)
7986import Data.Aeson
8087import Data.Aeson.Types
8188import Data.ByteArray
8289import Data.ByteArray.Encoding
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
90+import Data.ByteString (ByteString)
91+import Data.ByteString.Builder (Builder)
92+import qualified Data.ByteString.Builder as Build
93+import qualified Data.ByteString.Char8 as BS8
94+import qualified Data.ByteString.Lazy as LBS
8895import Data.Coerce
89−import Data.Default.Class (def)
90−import Data.List (intersperse)
96+import Data.Default.Class (def)
97+import Data.List
9198import Data.String
92−import qualified Data.Text as Text
93−import qualified Data.Text.Encoding as Text
99+import qualified Data.Text as Text
100+import qualified Data.Text.Encoding as Text
94101import Data.Time
95102import Data.Time.Clock.POSIX
96103import Data.Typeable
97104import Data.X509
98105import Data.X509.Memory
99−import Network.Google.Auth.ApplicationDefaultCredentials
106+import GHC.Exts (Constraint)
107+import GHC.TypeLits
108+import Network.Google.Auth.ApplicationDefault
100109import Network.Google.Auth.Device
101110import Network.Google.Auth.InstalledApplication
102111import Network.Google.Auth.ServiceAccount
@@ -104,105 +113,110 @@ import Network.Google.Compute.Metadata
104113import Network.Google.Internal.Auth
105114import Network.Google.Internal.Logger
106115import Network.Google.Prelude
107−import Network.HTTP.Conduit hiding
108− (Request)
109−import qualified Network.HTTP.Conduit as Client
116+import Network.HTTP.Conduit hiding (Proxy)
117+import qualified Network.HTTP.Conduit as Client
110118import Network.HTTP.Types
111−import System.Directory (doesFileExist, getHomeDirectory)
112−import System.Environment (lookupEnv)
113−import System.FilePath ((</>))
114−import System.Info (os)
119+
115120
116121-- | An 'OAuthToken' that can potentially be expired, with the original
117122-- credentials that can be used to perform a refresh.
118−data Auth = Auth
119− { _credentials :: !Credentials
123+data Auth (s :: [*]) = Auth
124+ { _credentials :: !(Credentials s)
120125 , _token :: !OAuthToken
121126 }
122127
123−-- | Check if the given token is still valid, ie. younger than the projected
124−-- expiry time.
125−--
126−-- This deliberately makes no external calls due to the absolute construction of
127−-- the '_tokenExpiry' field, unlike the
128−-- <https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken documented>
129−-- validation method.
130−validate :: MonadIO m => Auth -> m Bool
131−validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime
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 () () = ()
132135
133−type Store = MVar Auth
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
141+
142+-- authorize :: (MonadIO m, MonadCatch m)
143+-- => Credentials s
144+-- -> Logger
145+-- -> Manager
146+-- -> m (Store s)
147+-- authorize = undefined
134148
135149-- | Construct storage containing the credentials which have not yet been
136150-- exchanged or refreshed.
137151initStore :: (MonadIO m, MonadCatch m)
138− => Credentials
139− -> Logger
140− -> Manager
141− -> m Store
142−initStore c l m = exchange c l m >>= liftIO . newMVar
143−
144−-- | Concurrently read the current token, and if expired, then
145−-- safely perform a single serial refresh.
146−getToken :: (MonadIO m, MonadCatch m)
147− => Store
148− -> Logger
149− -> Manager
150− -> m OAuthToken
151−getToken s l m = do
152− x <- liftIO (readMVar s)
153− mx <- validate x
154− if mx
155− then pure (_token x)
156− else liftIO . modifyMVar s $ \y -> do
157− my <- validate y
158− if my
159− then pure (y, _token y)
160− else do
161− z <- refresh y l m
162− pure (z, _token z)
163−
164−-- | Perform the initial credentials exchange to obtain a valid 'OAuthToken'
165−-- suitable for authorizing requests.
166−exchange :: (MonadIO m, MonadCatch m)
167− => Credentials
168− -> Logger
169− -> Manager
170− -> m Auth
171−exchange c l = fmap (Auth c) . action l
172− where
173− action = case c of
174− FromMetadata s -> metadataToken s
175− FromAccount a ss -> serviceAccountToken a ss
176− FromClient c n -> exchangeCode c n
177− FromUser u -> authorizedUserToken u Nothing
178−
179−-- | Refresh an existing 'OAuthToken' using
180−refresh :: (MonadIO m, MonadCatch m)
181− => Auth
182− -> Logger
183− -> Manager
184− -> m Auth
185−refresh (Auth c t) 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 x _ -> refreshToken x t
191− FromUser u -> authorizedUserToken u (_tokenRefresh t)
192−
193−-- | Apply the (by way of possible token refresh) a bearer token to the
194−-- authentication header of a request.
195−authorize :: (MonadIO m, MonadCatch m)
196− => Client.Request
197− -> Store
152+ => Credentials s
198153 -> Logger
199154 -> Manager
200− -> m Client.Request
201−authorize rq s l m = bearer <$> getToken s l m
202− where
203− bearer t = rq
204− { Client.requestHeaders =
205− ( hAuthorization
206− , "Bearer " <> Text.encodeUtf8 (toText (_tokenAccess t))
207− ) : Client.requestHeaders rq
208− }
155+ -> 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+-- }