@@ -21,32 +21,56 @@
2121module Network.Google.Auth where
2222
2323import Control.Concurrent
24−import Control.Concurrent.MVar
25−import Data.Char (toLower)
26−-- import Control.Exception
2724import Control.Exception.Lens
2825import Control.Lens
2926import Control.Monad
3027import Control.Monad.Catch
3128import Control.Monad.IO.Class
3229import Data.Aeson
33−import Data.ByteString (ByteString)
34−import qualified Data.ByteString.Lazy as LBS
35−import Data.Default.Class (def)
36−import qualified Data.HashMap.Strict as Map
37−import Data.Text (Text)
38−import qualified Data.Text as Text
39−import qualified Data.Text.Encoding as Text
30+import Data.ByteString (ByteString)
31+import qualified Data.ByteString.Lazy as LBS
32+import Data.Char (toLower)
33+import Data.Default.Class (def)
34+import qualified Data.Text as Text
35+import qualified Data.Text.Encoding as Text
4036import Data.Time
4137import Data.Typeable
4238import Network.Google.Prelude
4339import Network.HTTP.Conduit
44−import qualified Network.HTTP.Conduit as Client
40+import qualified Network.HTTP.Conduit as Client
4541import Network.HTTP.Types
46−import System.Directory (doesFileExist, getHomeDirectory)
47−import System.Environment (lookupEnv)
48−import System.FilePath ((</>))
49−import System.Info (os)
42+import System.Directory (doesFileExist, getHomeDirectory)
43+import System.Environment (lookupEnv)
44+import System.FilePath ((</>))
45+import System.Info (os)
46+
47+accountsHost, metadataHost :: ByteString
48+accountsHost = "accounts.google.com"
49+metadataHost = "metadata.google.internal"
50+
51+metadataFlavorHeader :: HeaderName
52+metadataFlavorHeader = "Metadata-Flavor"
53+
54+metadataFlavorDesired :: ByteString
55+metadataFlavorDesired = "Google"
56+
57+noGCECheck :: String
58+noGCECheck = "NO_GCE_CHECK"
59+
60+-- | The environment variable name which can replace ~/.config if set.
61+cloudSDKCredentialsDirVar :: String
62+cloudSDKCredentialsDirVar = "CLOUDSDK_CONFIG"
63+
64+cloudSDKCredentialsDir :: FilePath
65+cloudSDKCredentialsDir = "gcloud"
66+
67+cloudSDKCredentialsFile :: FilePath
68+cloudSDKCredentialsFile = "application_default_credentials.json"
69+
70+-- | The environment variable pointing the file with local
71+-- Application Default Credentials.
72+defaultCredentialsFileVar :: String
73+defaultCredentialsFileVar = "GOOGLE_APPLICATION_CREDENTIALS"
5074
5175data AuthError
5276 = RetrievalError HttpException
@@ -72,9 +96,13 @@ class AsAuthError a where
7296 -- | An error occured parsing the default credentials file.
7397 _InvalidFileError :: Prism' a (FilePath, Text)
7498
75− _RetrievalError = _AuthError . _RetrievalError
76− _MissingFileError = _AuthError . _MissingFileError
77− _InvalidFileError = _AuthError . _InvalidFileError
99+ -- | An error occured when attempting to refresh a token.
100+ _TokenRefreshError :: Prism' a (Status, Text, Maybe Text)
101+
102+ _RetrievalError = _AuthError . _RetrievalError
103+ _MissingFileError = _AuthError . _MissingFileError
104+ _InvalidFileError = _AuthError . _InvalidFileError
105+ _TokenRefreshError = _AuthError . _TokenRefreshError
78106
79107instance AsAuthError SomeException where
80108 _AuthError = exception
@@ -82,78 +110,25 @@ instance AsAuthError SomeException where
82110instance AsAuthError AuthError where
83111 _AuthError = id
84112
85− -- _RetrievalError = prism RetrievalError $ \case
86− -- RetrievalError e -> Right e
87− -- x -> Left x
88−
89− -- _MissingEnvError = prism MissingEnvError $ \case
90− -- MissingEnvError e -> Right e
91− -- x -> Left x
92−
93− -- _MissingFileError = prism MissingFileError $ \case
94− -- MissingFileError f -> Right f
95− -- x -> Left x
96−
97− -- _InvalidFileError = prism InvalidFileError $ \case
98− -- InvalidFileError e -> Right e
99− -- x -> Left x
100−
101−accountsHost = "accounts.google.com"
102−
103−metadataHost = "metadata.google.internal"
104−metadataFlavorHeader = "Metadata-Flavor"
105−metadataFlavorDesired = "Google"
106−
107−noGCECheck = "NO_GCE_CHECK"
108−
109−detectGCE :: MonadIO m => Manager -> m Bool
110−detectGCE m = liftIO $ do
111− p <- check <$> lookupEnv noGCECheck
112− if p
113− then (success <$> httpLbs rq m) `catch` failure
114− else pure False
115− where
116− check Nothing = True
117− check (Just x) = map toLower x `notElem` ["1", "true", "yes", "on"]
118−
119− success rs =
120− fromEnum (responseStatus rs) == 200
121− && (lookup metadataFlavorHeader (responseHeaders rs)
122− == Just metadataFlavorDesired)
123−
124− failure :: HttpException -> IO Bool
125− failure = const (pure False)
126−
127− rq = def
128− { Client.host = metadataHost
129− , Client.checkStatus = \_ _ _ -> Nothing
130− , Client.responseTimeout = Just 1000000
131− , Client.requestHeaders =
132− [ (metadataFlavorHeader, metadataFlavorDesired)
133− ]
134− }
135−
136−-- | The environment variable name which can replace ~/.config if set.
137−cloudSDKCredentialsDirVar = "CLOUDSDK_CONFIG"
138−cloudSDKCredentialsDir = "gcloud"
139−cloudSDKCredentialsFile = "application_default_credentials.json"
113+ _RetrievalError = prism RetrievalError $ \case
114+ RetrievalError e -> Right e
115+ x -> Left x
140116
141−cloudSDKCredentialsPath :: MonadIO m => m FilePath
142−cloudSDKCredentialsPath = liftIO $ do
143− v <- lookupEnv cloudSDKCredentialsDirVar
144− h <- getHomeDirectory
145− let d = case v of
146− Nothing | os == "windows" -> h </> cloudSDKCredentialsDir
147− Nothing -> h </> ".config" </> cloudSDKCredentialsDir
148− Just x -> h </> x
149− pure $! d </> cloudSDKCredentialsFile
117+ _MissingFileError = prism MissingFileError $ \case
118+ MissingFileError f -> Right f
119+ x -> Left x
150120
151−-- | The environment variable pointing the file with local
152−-- Application Default Credentials.
153−defaultCredentialsFileVar = "GOOGLE_APPLICATION_CREDENTIALS"
121+ _InvalidFileError = prism
122+ (uncurry InvalidFileError)
123+ (\case
124+ InvalidFileError f e -> Right (f, e)
125+ x -> Left x)
154126
155−defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
156−defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFileVar)
127+ _TokenRefreshError = prism
128+ (\(s, e, d) -> TokenRefreshError s e d)
129+ (\case
130+ TokenRefreshError s e d -> Right (s, e, d)
131+ x -> Left x)
157132
158133data Credentials
159134 = FromToken !OAuthToken
@@ -224,6 +199,46 @@ refreshToken (Ref m r) = do
224199isValid :: Refresh a -> IO Bool
225200isValid r = (< _rExpiry r) <$> getCurrentTime
226201
202+cloudSDKCredentialsPath :: MonadIO m => m FilePath
203+cloudSDKCredentialsPath = liftIO $ do
204+ v <- lookupEnv cloudSDKCredentialsDirVar
205+ h <- getHomeDirectory
206+ let d = case v of
207+ Nothing | os == "windows" -> h </> cloudSDKCredentialsDir
208+ Nothing -> h </> ".config" </> cloudSDKCredentialsDir
209+ Just x -> h </> x
210+ pure $! d </> cloudSDKCredentialsFile
211+
212+defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
213+defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFileVar)
214+
215+detectGCE :: MonadIO m => Manager -> m Bool
216+detectGCE m = liftIO $ do
217+ p <- check <$> lookupEnv noGCECheck
218+ if p
219+ then (success <$> httpLbs rq m) `catch` failure
220+ else pure False
221+ where
222+ check Nothing = True
223+ check (Just x) = map toLower x `notElem` ["1", "true", "yes", "on"]
224+
225+ success rs =
226+ fromEnum (responseStatus rs) == 200
227+ && (lookup metadataFlavorHeader (responseHeaders rs)
228+ == Just metadataFlavorDesired)
229+
230+ failure :: HttpException -> IO Bool
231+ failure = const (pure False)
232+
233+ rq = def
234+ { Client.host = metadataHost
235+ , Client.checkStatus = \_ _ _ -> Nothing
236+ , Client.responseTimeout = Just 1000000
237+ , Client.requestHeaders =
238+ [ (metadataFlavorHeader, metadataFlavorDesired)
239+ ]
240+ }
241+
227242data User = User
228243 { _uId :: !ClientId
229244 , _uSecret :: !Text