diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/google-oauth2.cabal b/google-oauth2.cabal --- a/google-oauth2.cabal +++ b/google-oauth2.cabal @@ -1,82 +1,61 @@ -Name: google-oauth2 -Version: 0.2.2 -Author: Pat Brisbin -Maintainer: Pat Brisbin -License: MIT -License-File: LICENSE -Synopsis: Google OAuth2 token negotiation -Description: - Interacting with the Google OAuth2 authorization API - . - 1. Prompt the user for a verification code - 2. POST that code to the Google API for a set of tokens (access and refresh) - 3. Use the access token until it expires - 4. Use the refresh token to get a new access token - 5. Repeat from 3 - . - Example usage: - . - > import Data.Monoid - > import Network.Google.OAuth2 - > import Network.HTTP.Conduit - > import Network.HTTP.Types (hAuthorization) - > - > import qualified Data.ByteString.Char8 as B8 - > import qualified Data.ByteString.Lazy.Char8 as L8 - > - > main :: IO () - > main = do - > let client = OAuth2Client clientId clientSecret - > scopes = ["https://www.googleapis.com/auth/drive"] - > - > token <- getAccessToken client scopes Nothing - > - > request <- parseUrl "https://www.googleapis.com/drive/v2/files" - > response <- withManager $ httpLbs $ authorize token request - > - > L8.putStrLn $ responseBody response - > - > where - > authorize token request = request - > -- Note: haddock chokes on curly braces for some reason, so I'm using - > -- parens here instead. - > ( requestHeaders = [(hAuthorization, B8.pack $ "Bearer " <> token)] ) - > - > -- Setup in Google Developers Console - > clientId = "..." - > clientSecret = "..." - . +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: a8210f3cdc16ee63542ebfbc6b0d085387f5a259853791163818eec24fe4224f -Cabal-Version: >= 1.10 -Build-Type: Simple +name: google-oauth2 +version: 0.3.0.0 +synopsis: Google OAuth2 token negotiation +description: See https://github.com/pbrisbin/google-oauth2#readme +homepage: https://github.com/pbrisbin/google-oauth2#readme +bug-reports: https://github.com/pbrisbin/google-oauth2/issues +author: Pat Brisbin +maintainer: Pat Brisbin +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 -Library - Default-Language: Haskell2010 - HS-Source-Dirs: src - GHC-Options: -Wall - Exposed-Modules: Network.Google.OAuth2 - Build-Depends: base >= 4 && < 5 - , HTTP >= 4000.2 && < 4000.4 - , aeson >= 0.8 && < 0.12 - , bytestring - , http-conduit - Default-Extensions: OverloadedStrings - RecordWildCards +source-repository head + type: git + location: https://github.com/pbrisbin/google-oauth2 -Test-Suite spec - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - Hs-Source-Dirs: test - Ghc-Options: -Wall - Main-Is: Spec.hs - Build-Depends: base - , google-oauth2 - , hspec - , bytestring - , http-conduit - , http-types - , load-env +library + hs-source-dirs: + src + ghc-options: -Wall -Wall + build-depends: + base >=4 && <5 + , bytestring + , hoauth2 + , http-client-tls + , safe-exceptions + , text + , transformers + , uri-bytestring + exposed-modules: + Network.Google.OAuth2 + other-modules: + Paths_google_oauth2 + default-language: Haskell2010 -Source-Repository head - Type: git - Location: https://github.com/pbrisbin/google-oauth2 +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -Wall -Wall + build-depends: + base >=4 && <5 + , bytestring + , google-oauth2 + , hoauth2 + , hspec + , http-conduit + , load-env + , text + other-modules: + Network.Google.OAuth2Spec + Paths_google_oauth2 + default-language: Haskell2010 diff --git a/src/Network/Google/OAuth2.hs b/src/Network/Google/OAuth2.hs --- a/src/Network/Google/OAuth2.hs +++ b/src/Network/Google/OAuth2.hs @@ -1,223 +1,95 @@ -{-# LANGUAGE CPP #-} -module Network.Google.OAuth2 - ( - -- * Types - Credentials(..) - , OAuth2Client(..) - , OAuth2Code - , OAuth2Scope - , OAuth2Token - , OAuth2Tokens(..) - - -- * Getting an access token - , getAccessToken +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} - -- * Lower-level steps - , newCreds - , refreshCreds - , promptForCode - , exchangeCode +module Network.Google.OAuth2 + ( getAccessToken ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>),(<*>)) -#endif - -import Control.Arrow (second) -import Control.Monad (mzero, void) -import Data.Aeson -import Data.ByteString (ByteString) -import Data.List (intercalate) -import Data.Maybe (fromJust) -import Data.Monoid ((<>)) -import Network.HTTP.Conduit - ( Response(..) - , httpLbs - , newManager - , parseUrlThrow - , tlsManagerSettings - , urlEncodedBody - ) -import Network.HTTP.Base (urlEncode) -import System.IO (hFlush, stdout) - -import qualified Control.Exception as E +import Control.Exception.Safe (handleIO, throwString) +import Control.Monad ((<=<)) +import Control.Monad.Trans.Maybe import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as BL - -type OAuth2Code = String -type OAuth2Scope = String -type OAuth2Token = String - --- | OAuth2 client definition --- --- https://developers.google.com/console/help/new/#generatingoauth2 --- -data OAuth2Client = OAuth2Client - { clientId :: !String - , clientSecret :: !String - } - deriving (Read, Show) - -data OAuth2Tokens = OAuth2Tokens - { accessToken :: !OAuth2Token - , refreshToken :: !OAuth2Token - , expiresIn :: !Int - , tokenType :: !String - } - deriving (Read, Show) - -instance FromJSON OAuth2Tokens where - parseJSON (Object o) = OAuth2Tokens - <$> o .: "access_token" - <*> o .: "refresh_token" - <*> o .: "expires_in" - <*> o .: "token_type" - - parseJSON _ = mzero - --- Used only when refreshing a token, where the response lacks the originally --- supplied refresh_token -data RefreshResponse = RefreshResponse - { rAccessToken :: OAuth2Token - , rExpiresIn :: Int - , rTokenType :: String - } +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Client.TLS (getGlobalManager) +import Network.OAuth.OAuth2 +import System.IO (hFlush, stdout) +import Text.Read (readMaybe) +import URI.ByteString (serializeURIRef') +import URI.ByteString.QQ (uri) -instance FromJSON RefreshResponse where - parseJSON (Object o) = RefreshResponse - <$> o .: "access_token" - <*> o .: "expires_in" - <*> o .: "token_type" +deriving instance Read IdToken +deriving instance Read AccessToken +deriving instance Read RefreshToken +deriving instance Read OAuth2Token - parseJSON _ = mzero +getAccessToken + :: Text -- ^ Client Id + -> Text -- ^ Client Secret + -> [Text] -- ^ Scopes + -> Maybe FilePath -- ^ File in which to cache the token + -> IO OAuth2Token -- ^ Refreshed token +getAccessToken clientId clientSecret scopes mPath = do + mgr <- getGlobalManager + token <- cached mPath $ do + code <- prompt $ unlines + [ "" + , "Visit the following URL to retrieve a verification code:" + , "" + , C8.unpack $ serializeURIRef' $ authorizationUrl oauth2 + , "" + , "Verification code: " + ] -toOAuth2Tokens :: OAuth2Token -> RefreshResponse -> OAuth2Tokens -toOAuth2Tokens token RefreshResponse{..} = - OAuth2Tokens - { accessToken = rAccessToken - , refreshToken = token - , expiresIn = rExpiresIn - , tokenType = rTokenType + fetchAccessToken' mgr $ ExchangeToken $ T.pack code + maybe (pure token) (refreshAccessToken' mgr) $ refreshToken token + where + oauth2 = OAuth2 + { oauthClientId = clientId + , oauthClientSecret = clientSecret + , oauthOAuthorizeEndpoint = + appendQueryParams + [ ("redirect_uri", "urn:ietf:wg:oauth:2.0:oob") + , ("scope", C8.intercalate " " $ map encodeUtf8 scopes) + ] + [uri|https://accounts.google.com/o/oauth2/auth|] + , oauthAccessTokenEndpoint = + appendQueryParams + [ ("redirect_uri", "urn:ietf:wg:oauth:2.0:oob") + ] + [uri|https://www.googleapis.com/oauth2/v3/token|] + , oauthCallback = Nothing } --- | Pairs a client and its tokens --- --- This type is primarily so they can be cached together and not require access --- the client id when using cached tokens --- -data Credentials = Credentials - { credsClient :: OAuth2Client - , credsTokens :: OAuth2Tokens - } - deriving (Read, Show) - --- | Get a valid access token with the given scopes --- --- If given, credentials are cached in a file, thus preventing the need for any --- prompting on subsequent reuse. N.B. this function always refreshes the access --- token before returning it. --- -getAccessToken :: OAuth2Client - -> [OAuth2Scope] - -> Maybe FilePath -- ^ File in which to cache the token - -> IO OAuth2Token -- ^ Refreshed token -getAccessToken client scopes (Just tokenFile) = do - cached <- cachedValue tokenFile - creds <- case cached of - Just c -> return c - Nothing -> newCreds client scopes - - refreshed <- refreshCreds creds - void $ cacheValue tokenFile refreshed - - return $ accessToken $ credsTokens refreshed - -getAccessToken client scopes Nothing = do - creds <- newCreds client scopes - refreshed <- refreshCreds creds - - return $ accessToken $ credsTokens refreshed - --- | Prompt the user for a verification code and exchange it for tokens -newCreds :: OAuth2Client -> [OAuth2Scope] -> IO Credentials -newCreds client scopes = do - code <- promptForCode client scopes - tokens <- exchangeCode client code + fetchAccessToken' m = fromEither <=< fetchAccessToken m oauth2 + refreshAccessToken' m = fromEither <=< refreshAccessToken m oauth2 - return $ Credentials client tokens + fromEither = either (throwString . show) pure --- | Prompt the user for a verification code -promptForCode :: OAuth2Client -> [OAuth2Scope] -> IO OAuth2Code -promptForCode client scopes = do - putStrLn "" - putStrLn "Visit the following URL to retrieve a verification code:" - putStrLn "" - putStrLn $ permissionUrl client scopes - putStrLn "" - putStr "Verification code: " +prompt :: String -> IO String +prompt msg = do + putStr msg hFlush stdout - getLine --- | Exchange a verification code for tokens -exchangeCode :: OAuth2Client -> OAuth2Code -> IO OAuth2Tokens -exchangeCode client code = postTokens - [ ("client_id", clientId client) - , ("client_secret", clientSecret client) - , ("grant_type", "authorization_code") - , ("redirect_uri", redirectUri) - , ("code", code) - ] - --- | Use the refresh token to get a new access token -refreshCreds :: Credentials -> IO Credentials -refreshCreds (Credentials client tokens) = do - refreshed <- postTokens - [ ("client_id", clientId client) - , ("client_secret", clientSecret client) - , ("grant_type", "refresh_token") - , ("refresh_token", refreshToken tokens) - ] - - return $ Credentials client - $ toOAuth2Tokens (refreshToken tokens) refreshed - -postTokens :: FromJSON a => [(ByteString, String)] -> IO a -postTokens params = do - request <- parseUrlThrow "https://accounts.google.com/o/oauth2/token" - - let params' = map (second C8.pack) params - - mngr <- newManager tlsManagerSettings - unsafeDecode <$> httpLbs (urlEncodedBody params' request) mngr - -cachedValue :: Read a => FilePath -> IO (Maybe a) -cachedValue tokenFile = do - result <- fmap (fmap reads) $ try $ readFile tokenFile - - return $ case result of - Right ((t,_):_) -> Just t - _ -> Nothing - -cacheValue :: Show a => FilePath -> a -> IO a -cacheValue tokenFile x = fmap (const x) $ try $ writeFile tokenFile (show x) - -permissionUrl :: OAuth2Client -> [OAuth2Scope] -> String -permissionUrl client scopes = - "https://accounts.google.com/o/oauth2/auth" - <> "?response_type=code" - <> "&client_id=" <> clientId client - <> "&redirect_uri=urn:ietf:wg:oauth:2.0:oob" - <> "&scope=" <> intercalate "+" (map urlEncode scopes) +cached :: (Read a, Show a) => Maybe FilePath -> IO a -> IO a +cached Nothing act = act +cached (Just fp) act = do + mResult <- runMaybeT $ do + c <- MaybeT $ readFileSafe fp + MaybeT $ pure $ readMaybe c -redirectUri :: String -redirectUri = "urn:ietf:wg:oauth:2.0:oob" + case mResult of + Just x -> pure x + _ -> do + x <- act + x <$ writeFileSafe fp (show x) --- With token responses, we assume that if we don't get an HTTP exception, then --- the response body will parse correctly. -unsafeDecode :: FromJSON a => Response BL.ByteString -> a -unsafeDecode = fromJust . decode . responseBody +readFileSafe :: FilePath -> IO (Maybe String) +readFileSafe = handleIO (const $ pure Nothing) . (Just <$>) . readFile -try :: IO a -> IO (Either E.IOException a) -try = E.try +writeFileSafe :: FilePath -> String -> IO () +writeFileSafe fp = handleIO (const $ pure ()) . writeFile fp diff --git a/test/Network/Google/OAuth2Spec.hs b/test/Network/Google/OAuth2Spec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Google/OAuth2Spec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.Google.OAuth2Spec + ( main + , spec + ) where + +import Test.Hspec + +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import LoadEnv +import Network.Google.OAuth2 +import Network.HTTP.Simple +import Network.OAuth.OAuth2 (AccessToken(..), OAuth2Token(..)) +import System.Environment + +-- | To run in an interactive way +-- +-- So you can perform the OAuth2 flow +-- +-- > stack exec runghc test/Network/Google/OAuth2Spec.hs +-- +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Token exchange" $ do + it "grants access to an API" $ do + loadEnv + clientId <- T.pack <$> getEnv "CLIENT_ID" + clientSecret <- T.pack <$> getEnv "CLIENT_SECRET" + scope <- T.pack <$> getEnv "EXAMPLE_SCOPE" + exampleUrl <- getEnv "EXAMPLE_URL" + + OAuth2Token{..} <- getAccessToken clientId clientSecret [scope] + $ Just "test/oauth.token" + + request <- parseRequest exampleUrl + response <- httpLBS $ authorize (atoken accessToken) request + getResponseBody response `shouldSatisfy` (not . L8.null) + +authorize :: Text -> Request -> Request +authorize token = setRequestHeaders + [ ("Authorization", encodeUtf8 $ "Bearer " <> token) + ]