diff --git a/gogol/src/Network/Google/Auth.hs b/gogol/src/Network/Google/Auth.hs index f224b7300b..81feda8f35 100644 --- a/gogol/src/Network/Google/Auth.hs +++ b/gogol/src/Network/Google/Auth.hs @@ -22,6 +22,8 @@ module Network.Google.Auth , getApplicationDefault , fromWellKnownPath , fromFilePath + , saveAuthorizedUserToWellKnownPath + , saveAuthorizedUser -- ** Installed Application Credentials , installedApplication @@ -33,8 +35,10 @@ module Network.Google.Auth -- ** Thread-safe Storage , Store , initStore + , retrieveAuthFromStore , Auth (..) + , authToAuthorizedUser , exchange , refresh @@ -81,6 +85,19 @@ import Network.HTTP.Conduit (Manager) import qualified Network.HTTP.Conduit as Client import Network.HTTP.Types (hAuthorization) +-- | 'authToAuthorizedUser' converts 'Auth' into an 'AuthorizedUser' +-- by returning 'Right' if there is a 'FromClient'-constructed +-- Credentials and a refreshed token; otherwise, returning +-- 'Left' with error message. +authToAuthorizedUser :: AllowScopes s => Auth s -> Either Text AuthorizedUser +authToAuthorizedUser a = AuthorizedUser + <$> (_clientId <$> getClient) + <*> maybe (Left "no refresh token") Right (_tokenRefresh (_token a)) + <*> (_clientSecret <$> getClient) + where getClient = case _credentials a of + FromClient c _ -> Right c + _ -> Left "not FromClient" + -- | An 'OAuthToken' that can potentially be expired, with the original -- credentials that can be used to perform a refresh. data Auth (s :: [Symbol]) = Auth @@ -110,6 +127,12 @@ initStore :: (MonadIO m, MonadCatch m, AllowScopes s) -> m (Store s) initStore c l m = exchange c l m >>= fmap Store . liftIO . newMVar +-- | Retrieve auth from storage +retrieveAuthFromStore :: (MonadIO m, MonadCatch m, AllowScopes s) + => Store s + -> m (Auth s) +retrieveAuthFromStore (Store s) = liftIO (readMVar s) + -- | Concurrently read the current token, and if expired, then -- safely perform a single serial refresh. getToken :: (MonadIO m, MonadCatch m, AllowScopes s) diff --git a/gogol/src/Network/Google/Auth/ApplicationDefault.hs b/gogol/src/Network/Google/Auth/ApplicationDefault.hs index 436402e369..d2a46b4e98 100644 --- a/gogol/src/Network/Google/Auth/ApplicationDefault.hs +++ b/gogol/src/Network/Google/Auth/ApplicationDefault.hs @@ -20,20 +20,21 @@ module Network.Google.Auth.ApplicationDefault where import Control.Applicative import Control.Exception.Lens (catching, throwingM) -import Control.Monad (unless) +import Control.Monad (unless, when) import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO (..)) import Data.Aeson import Data.Aeson.Types (parseEither) import qualified Data.ByteString.Lazy as LBS +import Data.Maybe (maybe) import qualified Data.Text as Text import Network.Google.Compute.Metadata (isGCE) import Network.Google.Internal.Auth import Network.HTTP.Conduit (Manager) -import System.Directory (doesFileExist, getHomeDirectory) +import System.Directory (doesFileExist, getHomeDirectory, createDirectoryIfMissing) import System.Environment (lookupEnv) -import System.FilePath (()) +import System.FilePath ((), takeDirectory) import System.Info (os) -- | The environment variable name which is used to specify the directory @@ -126,6 +127,30 @@ fromFilePath f = do either (throwM . InvalidFileError f . Text.pack) pure (fromJSONCredentials bs) +-- | Save 'AuthorizedUser' +-- /See:/ 'cloudSDKConfigPath', 'defaultCredentialsPath'. +saveAuthorizedUserToWellKnownPath :: (MonadIO m, MonadCatch m) + => Bool -- ^ Force to save if True + -> AuthorizedUser + -> m () +saveAuthorizedUserToWellKnownPath b a = do + d <- defaultCredentialsPath + f <- maybe cloudSDKConfigPath pure d + liftIO $ createDirectoryIfMissing True $ takeDirectory f + saveAuthorizedUser f b a + +-- | Save 'AuthorizedUser' +saveAuthorizedUser :: (MonadIO m, MonadCatch m) + => FilePath + -> Bool -- ^ Force to save if True + -> AuthorizedUser + -> m () +saveAuthorizedUser f b a = do + p <- liftIO (doesFileExist f) + when (p && not b) $ + throwM (FileExistError f) + liftIO (LBS.writeFile f $ encode a) + -- | Attempt to parse either a @service_account@ or @authorized_user@ formatted -- JSON value to obtain credentials. fromJSONCredentials :: LBS.ByteString -> Either String (Credentials s) diff --git a/gogol/src/Network/Google/Auth/InstalledApplication.hs b/gogol/src/Network/Google/Auth/InstalledApplication.hs index d5e7faad37..be14fa9cec 100644 --- a/gogol/src/Network/Google/Auth/InstalledApplication.hs +++ b/gogol/src/Network/Google/Auth/InstalledApplication.hs @@ -22,9 +22,12 @@ module Network.Google.Auth.InstalledApplication ( installedApplication -- * Forming the URL + , AccessType (..) , redirectURI , formURL + , formAccessTypeURL , formURLWith + , formAccessTypeURLWith -- * Internal Exchange and Refresh , exchangeCode @@ -33,6 +36,7 @@ module Network.Google.Auth.InstalledApplication import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO) +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import GHC.TypeLits (Symbol) import Network.Google.Auth.Scope (AllowScopes (..), @@ -77,6 +81,9 @@ import qualified Network.HTTP.Conduit as Client installedApplication :: OAuthClient -> OAuthCode s -> Credentials s installedApplication = FromClient +-- /See:/ +data AccessType = Online | Offline deriving (Show, Eq) + -- | The redirection URI used in 'formURL': @urn:ietf:wg:oauth:2.0:oob@. redirectURI :: Text redirectURI = "urn:ietf:wg:oauth:2.0:oob" @@ -88,6 +95,12 @@ redirectURI = "urn:ietf:wg:oauth:2.0:oob" formURL :: AllowScopes (s :: [Symbol]) => OAuthClient -> proxy s -> Text formURL c = formURLWith c . allowScopes +-- | 'formURL' for 'AccessType' +-- +-- /See:/ 'formUrl'. +formAccessTypeURL :: AllowScopes (s :: [Symbol]) => OAuthClient -> AccessType -> proxy s -> Text +formAccessTypeURL c a = formAccessTypeURLWith c a . allowScopes + -- | Form a URL using 'OAuthScope' values. -- -- /See:/ 'formURL'. @@ -98,6 +111,13 @@ formURLWith c ss = accountsURL <> "&redirect_uri=" <> redirectURI <> "&scope=" <> Text.decodeUtf8 (queryEncodeScopes ss) +-- | 'formURLWith' for 'AccessType' +-- +-- /See:/ 'formURLWith'. +formAccessTypeURLWith :: OAuthClient -> AccessType -> [OAuthScope] -> Text +formAccessTypeURLWith c a ss = formURLWith c ss + <> "&access_type=" <> (Text.toLower . Text.pack $ show a) + -- | Exchange 'OAuthClient' details and the received 'OAuthCode' for a new -- 'OAuthToken'. -- diff --git a/gogol/src/Network/Google/Internal/Auth.hs b/gogol/src/Network/Google/Internal/Auth.hs index e1103574f9..e024a61711 100644 --- a/gogol/src/Network/Google/Internal/Auth.hs +++ b/gogol/src/Network/Google/Internal/Auth.hs @@ -129,6 +129,13 @@ data AuthorizedUser = AuthorizedUser , _userSecret :: !Secret } deriving (Eq, Show) +instance ToJSON AuthorizedUser where + toJSON (AuthorizedUser i r s) = + object [ "client_id" .= i + , "refresh_token" .= r + , "client_secret" .= s + ] + instance FromJSON AuthorizedUser where parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser <$> o .: "client_id" @@ -175,12 +182,13 @@ instance ToHttpApiData (OAuthCode s) where toQueryParam (OAuthCode c) = c toHeader (OAuthCode c) = Text.encodeUtf8 c --- | An error thrown when attempting to read AuthN/AuthZ information. +-- | An error thrown when attempting to read/write AuthN/AuthZ information. data AuthError = RetrievalError HttpException | MissingFileError FilePath | InvalidFileError FilePath Text | TokenRefreshError Status Text (Maybe Text) + | FileExistError FilePath deriving (Show, Typeable) instance Exception AuthError