git.iko.soy/gogol
on develop help sign in
Adding prisms for authentication errors
8b0f8eeBrendan Hay
gogol/src/Network/Google/Auth.hs+102−87
compare with develop
unifiedsplit
@@ -21,32 +21,56 @@
21module Network.Google.Auth where
21module Network.Google.Auth where
22
22
23import Control.Concurrent
23import Control.Concurrent
24−import Control.Concurrent.MVar
25−import Data.Char (toLower)
26−-- import Control.Exception
27import Control.Exception.Lens
24import Control.Exception.Lens
28import Control.Lens
25import Control.Lens
29import Control.Monad
26import Control.Monad
30import Control.Monad.Catch
27import Control.Monad.Catch
31import Control.Monad.IO.Class
28import Control.Monad.IO.Class
32import Data.Aeson
29import Data.Aeson
33−import Data.ByteString (ByteString)
30+import Data.ByteString (ByteString)
34−import qualified Data.ByteString.Lazy as LBS
31+import qualified Data.ByteString.Lazy as LBS
32+import Data.Char (toLower)
35−import Data.Default.Class (def)
33+import Data.Default.Class (def)
36−import qualified Data.HashMap.Strict as Map
34+import qualified Data.Text as Text
37−import Data.Text (Text)
38−import qualified Data.Text as Text
39−import qualified Data.Text.Encoding as Text
35+import qualified Data.Text.Encoding as Text
40import Data.Time
36import Data.Time
41import Data.Typeable
37import Data.Typeable
42import Network.Google.Prelude
38import Network.Google.Prelude
43import Network.HTTP.Conduit
39import Network.HTTP.Conduit
44−import qualified Network.HTTP.Conduit as Client
40+import qualified Network.HTTP.Conduit as Client
45import Network.HTTP.Types
41import Network.HTTP.Types
46−import System.Directory (doesFileExist, getHomeDirectory)
42+import System.Directory (doesFileExist, getHomeDirectory)
47−import System.Environment (lookupEnv)
43+import System.Environment (lookupEnv)
48−import System.FilePath ((</>))
44+import System.FilePath ((</>))
49−import System.Info (os)
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"
50
74
51data AuthError
75data AuthError
52 = RetrievalError HttpException
76 = RetrievalError HttpException
@@ -72,9 +96,13 @@ class AsAuthError a where
72 -- | An error occured parsing the default credentials file.
96 -- | An error occured parsing the default credentials file.
73 _InvalidFileError :: Prism' a (FilePath, Text)
97 _InvalidFileError :: Prism' a (FilePath, Text)
74
98
99+ -- | An error occured when attempting to refresh a token.
100+ _TokenRefreshError :: Prism' a (Status, Text, Maybe Text)
101+
75− _RetrievalError = _AuthError . _RetrievalError
102+ _RetrievalError = _AuthError . _RetrievalError
76− _MissingFileError = _AuthError . _MissingFileError
103+ _MissingFileError = _AuthError . _MissingFileError
77− _InvalidFileError = _AuthError . _InvalidFileError
104+ _InvalidFileError = _AuthError . _InvalidFileError
105+ _TokenRefreshError = _AuthError . _TokenRefreshError
78
106
79instance AsAuthError SomeException where
107instance AsAuthError SomeException where
80 _AuthError = exception
108 _AuthError = exception
@@ -82,78 +110,25 @@ instance AsAuthError SomeException where
82instance AsAuthError AuthError where
110instance AsAuthError AuthError where
83 _AuthError = id
111 _AuthError = id
84
112
85− -- _RetrievalError = prism RetrievalError $ \case
113+ _RetrievalError = prism RetrievalError $ \case
86− -- RetrievalError e -> Right e
114+ RetrievalError e -> Right e
87− -- x -> Left x
115+ 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"
140
116
141−cloudSDKCredentialsPath :: MonadIO m => m FilePath
117+ _MissingFileError = prism MissingFileError $ \case
142−cloudSDKCredentialsPath = liftIO $ do
118+ MissingFileError f -> Right f
143− v <- lookupEnv cloudSDKCredentialsDirVar
119+ x -> Left x
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
150
120
151−-- | The environment variable pointing the file with local
121+ _InvalidFileError = prism
152−-- Application Default Credentials.
122+ (uncurry InvalidFileError)
153−defaultCredentialsFileVar = "GOOGLE_APPLICATION_CREDENTIALS"
123+ (\case
124+ InvalidFileError f e -> Right (f, e)
125+ x -> Left x)
154
126
155−defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
127+ _TokenRefreshError = prism
156−defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFileVar)
128+ (\(s, e, d) -> TokenRefreshError s e d)
129+ (\case
130+ TokenRefreshError s e d -> Right (s, e, d)
131+ x -> Left x)
157
132
158data Credentials
133data Credentials
159 = FromToken !OAuthToken
134 = FromToken !OAuthToken
@@ -224,6 +199,46 @@ refreshToken (Ref m r) = do
224isValid :: Refresh a -> IO Bool
199isValid :: Refresh a -> IO Bool
225isValid r = (< _rExpiry r) <$> getCurrentTime
200isValid r = (< _rExpiry r) <$> getCurrentTime
226
201
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+
227data User = User
242data User = User
228 { _uId :: !ClientId
243 { _uId :: !ClientId
229 , _uSecret :: !Text
244 , _uSecret :: !Text