@@ -1,4 +1,8 @@
1+{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
26{-# LANGUAGE GeneralizedNewtypeDeriving #-}
37{-# LANGUAGE LambdaCase #-}
48{-# LANGUAGE OverloadedStrings #-}
@@ -20,6 +24,7 @@ import Control.Concurrent
2024import Control.Concurrent.MVar
2125import Control.Exception
2226import Control.Exception.Lens
27+import Control.Lens
2328import Control.Monad
2429import Control.Monad.Catch
2530import Control.Monad.IO.Class
@@ -38,24 +43,79 @@ import Network.HTTP.Conduit
3843-- import qualified Network.HTTP.Client.Conduit as C
3944import qualified Network.HTTP.Conduit as Client
4045import Network.HTTP.Types
41−import System.Directory (getHomeDirectory)
46+import System.Directory (doesFileExist, getHomeDirectory)
4247import System.Environment (lookupEnv)
4348import System.FilePath ((</>))
4449import System.Info (os)
4550
46−-- withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a
47−-- withAuth (Ref _ r) f = liftIO (readIORef r) >>= f
48−-- withAuth (Auth e) f = f e
51+data Credentials
52+ = FromToken !OAuthToken
53+ | FromFile !FilePath
54+ | Discover
55+ deriving (Eq, Show)
56+
57+getAuth :: MonadIO m => Manager -> Credentials -> m Auth
58+getAuth m = \case
59+ FromToken t -> pure (fromToken t)
60+ FromFile f -> fromFilePath m f
61+ Discover -> undefined
62+ -- catching _MissingFileError fromFile $ \f -> do
63+ -- p <- detectGCE m
64+ -- unless p $
65+ -- throwingM _MissingFileError f
66+ -- fromMetadata m
67+
68+fromToken :: OAuthToken -> Auth
69+fromToken = Tok
4970
50−-- -- | Retrieve authentication information via the specified 'Credentials' mechanism.
51−-- getAuth :: Monad m => Credentials -> m Auth
52−-- getAuth = \case
53−-- FromKey k -> pure $! Auth (AuthEnv (Left k) Nothing)
54−-- FromToken t -> pure $! Auth (AuthEnv (Right t) Nothing)
71+fromFile :: MonadIO m => Manager -> m Auth
72+fromFile m = defaultCredentialsPath >>= fromFilePath m
5573
74+fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth
75+fromFilePath m f = liftIO $ do
76+ p <- doesFileExist f
77+ unless p $
78+ throwM (MissingFileError f)
79+ !u <- LBS.readFile f >>=
80+ either (throwM . InvalidFileError f) pure . parseLBS
81+ !r <- refresh m u
82+ Ref m <$> newMVar (r :: Refresh User)
5683
57−-- -- | Expiry is stored in RFC3339 UTC format
58−-- EXPIRY_FORMAT = "%Y-%m-%dT%H:%M:%SZ"
84+fromMetadata :: MonadIO m => Manager -> ServiceId -> m Auth
85+fromMetadata m s = liftIO $ do
86+ !r <- refresh m s
87+ Ref m <$> newMVar (r :: Refresh ServiceId)
88+
89+data Auth where
90+ Tok :: OAuthToken -> Auth
91+ Ref :: RefreshToken a => Manager -> MVar (Refresh a) -> Auth
92+
93+withToken :: MonadIO m => Auth -> (OAuthToken -> m a) -> m a
94+withToken x f = liftIO (refreshToken x) >>= f
95+
96+refreshToken :: Auth -> IO OAuthToken
97+refreshToken (Tok t) = pure t
98+refreshToken (Ref m r) = do
99+ x <- readMVar r
100+ xv <- isValid x
101+ if xv
102+ then pure (_rToken x)
103+ else modifyMVar r $ \y -> do
104+ yv <- isValid y
105+ if yv
106+ then pure (y, _rToken x)
107+ else do
108+ z <- refresh m (_rTarget y)
109+ pure (z, _rToken z)
110+
111+isValid :: Refresh a -> IO Bool
112+isValid r = (< _rExpiry r) <$> getCurrentTime
113+
114+-- GOOGLE_AUTH_URI = 'https://accounts.google.com/o/oauth2/auth'
115+-- GOOGLE_DEVICE_URI = 'https://accounts.google.com/o/oauth2/device/code'
116+-- GOOGLE_REVOKE_URI = 'https://accounts.google.com/o/oauth2/revoke'
117+-- GOOGLE_TOKEN_URI = 'https://accounts.google.com/o/oauth2/token'
118+-- GOOGLE_TOKEN_INFO_URI = 'https://www.googleapis.com/oauth2/v2/tokeninfo'
59119
60120-- -- | Which certs to use to validate id_tokens received.
61121-- ID_TOKEN_VERIFICATION_CERTS = "https://www.googleapis.com/oauth2/v1/certs"
@@ -129,8 +189,8 @@ detectGCE m = pure False
129189-- finally:
130190-- connection.close()
131191
132−isGAE :: MonadIO m => m Bool
133−isGAE = pure False
192+-- isGAE :: MonadIO m => m Bool
193+-- isGAE = pure False
134194 -- if SETTINGS.env_name is not None:
135195 -- return SETTINGS.env_name in ('GAE_PRODUCTION', 'GAE_LOCAL')
136196
@@ -148,8 +208,8 @@ isGAE = pure False
148208
149209 -- return False
150210
151−isGCE :: MonadIO m => m Bool
152−isGCE = pure False
211+-- isGCE :: MonadIO m => m Bool
212+-- isGCE = pure False
153213-- def _in_gce_environment():
154214-- """Detect if the code is running in the Compute Engine environment.
155215-- Returns:
@@ -163,14 +223,11 @@ isGCE = pure False
163223-- return True
164224-- return False
165225
166−newtype ClientId = ClientId { clientId :: Text }
167− deriving (Eq, Show, FromJSON, ToJSON)
168−
169226data AuthError
170227 = RetrievalError HttpException
171228 | MissingFileError FilePath
172229 | InvalidFileError FilePath Text
173− | TokenRefreshError Status ClientId Text (Maybe Text)
230+ | TokenRefreshError Status Text (Maybe Text)
174231 deriving (Show, Typeable)
175232
176233instance Exception AuthError
@@ -193,181 +250,115 @@ defaultCredentialsPath = liftIO $ do
193250 Just x -> h </> x
194251 pure $! d </> cloudSDKConfigFile
195252
196−data AuthorizedUser = AuthorizedUser
197− { _auClientId :: !ClientId
198− , _auClientSecret :: !Text
199− , _auRefreshToken :: !Text
253+data User = User
254+ { _uId :: !ClientId
255+ , _uSecret :: !Text
256+ , _uRefresh :: !Text
200257 }
201258
202−instance FromJSON AuthorizedUser where
203− parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser
259+instance FromJSON User where
260+ parseJSON = withObject "authorized_user" $ \o -> User
204261 <$> o .: "client_id"
205262 <*> o .: "client_secret"
206263 <*> o .: "refresh_token"
207264
208−data AuthorizedRefresh = AuthorizedRefresh
209− { _arAccessToken :: !OAuthToken
210− , _arRefreshToken :: !(Maybe Text)
211− , _arExpiresIn :: !NominalDiffTime
212− }
213−
214−instance FromJSON AuthorizedRefresh where
215− parseJSON = withObject "authorized_refresh" $ \o -> AuthorizedRefresh
216− <$> o .: "access_token"
217− <*> o .:? "refresh_token"
218− <*> (fromInteger <$> o .: "expires_in")
219−
220−data AuthorizedError = AuthorizedError
221− { _aeError :: !Text
222− , _aeDescription :: !(Maybe Text)
265+data RefreshError = RefreshError
266+ { _eError :: !Text
267+ , _eDescription :: !(Maybe Text)
223268 }
224269
225−instance FromJSON AuthorizedError where
226− parseJSON = withObject "authorized_error" $ \o -> AuthorizedError
270+instance FromJSON RefreshError where
271+ parseJSON = withObject "refresh_error" $ \o -> RefreshError
227272 <$> o .: "error"
228273 <*> o .:? "error_description"
229274
230−refreshUser :: Manager -> AuthorizedUser -> IO (Refresh AuthorizedUser)
231−refreshUser m u@AuthorizedUser {..} = do
232− rs <- httpLbs rq m
233− let bs = responseBody rs
234− s = responseStatus rs
235− if fromEnum s == 200 then success s bs else failure s bs
236− where
237− failure s bs = do
238− AuthorizedError {..} <- parseErr s bs
239− refreshErr s _aeError _aeDescription
240−
241− success s bs = do
242− AuthorizedRefresh {..} <- parseErr s bs
243− ts <- getCurrentTime
244− pure $! Refresh (addUTCTime _arExpiresIn ts) _arAccessToken $
245− u { _auRefreshToken = fromMaybe _auRefreshToken _arRefreshToken }
246−
247− parseErr s bs =
248− case parseLBS bs of
249− Left e -> refreshErr s e Nothing
250− Right x -> pure x
251−
252− refreshErr s e = throwM . TokenRefreshError s _auClientId e
253−
254− rq = def
255− { Client.host = "accounts.google.com"
256− , Client.port = 443
257− , Client.secure = True
258− , Client.checkStatus = \_ _ _ -> Nothing
259− , Client.method = "POST"
260− , Client.path = "/o/oauth2/token"
261− , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]
262− , Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
263− "grant_type=refresh_token"
264− <> "&client_id=" <> clientId _auClientId
265− <> "&client_secret=" <> _auClientSecret
266− <> "&refresh_token=" <> _auRefreshToken
267− }
268−
269−-- data ServiceAccount = ServiceAccount
270−-- { _saClientId :: !Text
271−-- , _saClientEmail :: !Text
272−-- , _saPrivateKeyId :: !Text
273−-- , _saPrivateKey :: !Text
274−-- }
275−
276−-- instance FromJSON ServiceAccount where
277−-- parseJSON = withObject "service_account" $ \o -> ServiceAccount
278−-- <$> o .: "client_id"
279−-- <*> o .: "client_email"
280−-- <*> o .: "private_key_id"
281−-- <*> o .: "private_key"
282−
283−data DefaultCredentials
284− = User !AuthorizedUser
285−-- | Account !ServiceAccount
286−
287−instance FromJSON DefaultCredentials where
288− parseJSON = withObject "default_credentials" $ \o -> do
289− t <- o .: "type"
290− case t of
291− "authorized_user" -> User <$> parseJSON (Object o)
292− "service_account" -> fail "type: 'service_account' not supported."
293− _ -> fail . Text.unpack $
294− "Unrecognized default credentials type: " <> t
295−
296275data Refresh a = Refresh
297− { _rExpiry :: !UTCTime
298− , _rToken :: !OAuthToken
276+ { _rToken :: !OAuthToken
277+ , _rExpiry :: !UTCTime
299278 , _rTarget :: !a
300279 }
301280
302−isValid :: Refresh a -> IO Bool
303−isValid r = do
304− ts <- getCurrentTime
305− pure $! ts < _rExpiry r
306−
307−data Auth
308− = Tok !OAuthToken
309− | Ref (MVar (Refresh AuthorizedUser))
310− (AuthorizedUser -> IO (Refresh AuthorizedUser))
311−
312−withToken :: MonadIO m => Auth -> (OAuthToken -> m a) -> m a
313−withToken x f = refreshToken x >>= f
314−
315−refreshToken :: MonadIO m => Auth -> m OAuthToken
316−refreshToken = liftIO . \case
317− Tok t -> pure t
318− Ref v f -> do
319− x <- readMVar v
320− xv <- isValid x
321− if xv
322− then pure (_rToken x)
323− else modifyMVar v $ \y -> do
324− yv <- isValid y
325− if yv
326− then pure (y, _rToken x)
327− else do
328− z <- f (_rTarget y)
329− pure (z, _rToken z)
330−
331−data Credentials
332− = FromToken !OAuthToken
333− | FromFile !FilePath
334− | Discover
335− deriving (Eq, Show)
336−
337−getAuth :: MonadIO m => Manager -> Credentials -> m Auth
338−getAuth m = \case
339− FromToken t -> pure (Tok t)
340− FromFile f -> undefined -- fromFilePath f
341− Discover -> undefined
342− -- catching _MissingFileError fromFile $ \f -> do
343− -- p <- detectGCE m
344− -- unless p $
345− -- throwingM _MissingFileError f
346− -- fromMetadata m
347−
348−-- fromFile :: MonadIO m => m Auth
349−-- fromFile = undefined -- defaultCredentialsPath >>= fromFilePath
350−
351−-- fromMetadata :: MonadIO m => Manager -> m Auth
352−-- fromMetadata m = liftIO $ do
353−-- !r <- refresh
354−-- Ref <$> newMVar r <*> pure refresh
355−-- where
356−-- refresh = do
357−-- bs <- httpLbs rq m
358−-- parseLBS
359−
360−-- GOOGLE_AUTH_URI = 'https://accounts.google.com/o/oauth2/auth'
361−-- GOOGLE_DEVICE_URI = 'https://accounts.google.com/o/oauth2/device/code'
362−-- GOOGLE_REVOKE_URI = 'https://accounts.google.com/o/oauth2/revoke'
363−-- GOOGLE_TOKEN_URI = 'https://accounts.google.com/o/oauth2/token'
364−-- GOOGLE_TOKEN_INFO_URI = 'https://www.googleapis.com/oauth2/v2/tokeninfo'
365−
366−-- fromFilePath :: MonadIO m => Manager -> FilePath -> m Auth
367−-- fromFilePath m f = liftIO $ do
368−-- p <- doesFileExist f
369−-- unless p $
370−-- throwM (MissingFileError f)
371−-- !u <- LBS.readFile f >>= either invalidErr pure . eitherDecode'
372−-- !r <- refresh m u
373−-- Ref <$> newMVar r <*> pure (refresh d)
281+instance FromJSON (UTCTime -> (Maybe Text -> a) -> Refresh a) where
282+ parseJSON = withObject "refresh_token" $ \o -> do
283+ t <- o .: "access_token"
284+ e <- o .: "expires_in" <&> fromInteger
285+ r <- o .:? "refresh_token"
286+ pure $ \ts f ->
287+ Refresh t (addUTCTime e ts) (f r)
288+
289+class RefreshToken a where
290+ refresh :: Manager -> a -> IO (Refresh a)
291+
292+instance RefreshToken User where
293+ refresh m u@User {..} = do
294+ rs <- httpLbs rq m
295+ let bs = responseBody rs
296+ s = responseStatus rs
297+ if fromEnum s == 200 then success s bs else failure s bs
298+ where
299+ failure s bs = do
300+ RefreshError {..} <- parseErr s bs
301+ refreshErr s _eError _eDescription
302+
303+ success s bs = do
304+ f <- parseErr s bs
305+ ts <- getCurrentTime
306+ pure $! f ts $ \r ->
307+ u { _uRefresh = fromMaybe _uRefresh r
308+ }
309+
310+ parseErr s bs =
311+ case parseLBS bs of
312+ Left e -> refreshErr s e Nothing
313+ Right !x -> pure x
314+
315+ refreshErr s e = throwM . TokenRefreshError s e
316+
317+ rq = def
318+ { Client.host = "accounts.google.com"
319+ , Client.port = 443
320+ , Client.secure = True
321+ , Client.checkStatus = \_ _ _ -> Nothing
322+ , Client.method = "POST"
323+ , Client.path = "/o/oauth2/token"
324+ , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]
325+ , Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
326+ "grant_type=refresh_token"
327+ <> "&client_id=" <> clientIdToText _uId
328+ <> "&client_secret=" <> _uSecret
329+ <> "&refresh_token=" <> _uRefresh
330+ }
331+
332+instance RefreshToken ServiceId where
333+ refresh m sid = do
334+ rs <- httpLbs rq m
335+ let bs = responseBody rs
336+ s = responseStatus rs
337+ if fromEnum s == 200 then success s bs else failure s
338+ where
339+ failure s =
340+ refreshErr s "Failure refreshing token from http://metadata.google.internal"
341+ Nothing
342+
343+ success s bs = do
344+ f <- parseErr s bs
345+ ts <- getCurrentTime
346+ pure $! f ts (const sid :: Maybe Text -> ServiceId)
347+
348+ parseErr s bs =
349+ case parseLBS bs of
350+ Left e -> refreshErr s e Nothing
351+ Right !x -> pure x
352+
353+ refreshErr s e = throwM . TokenRefreshError s e
354+
355+ rq = def
356+ { Client.host = "metadata.google.internal"
357+ , Client.port = 80
358+ , Client.secure = False
359+ , Client.checkStatus = \_ _ _ -> Nothing
360+ , Client.method = "GET"
361+ , Client.path = "/computeMetadata/v1/instance/service-accounts/"
362+ <> Text.encodeUtf8 (serviceIdToText sid)
363+ <> "/token"
364+ }