packages feed

google-oauth2 0.2.2 → 0.3.0.0

raw patch · 4 files changed

+185/−286 lines, 4 filesdep +hoauth2dep +http-client-tlsdep +safe-exceptionsdep −HTTPdep −aesondep −http-typesdep ~basesetup-changed

Dependencies added: hoauth2, http-client-tls, safe-exceptions, text, transformers, uri-bytestring

Dependencies removed: HTTP, aeson, http-types

Dependency ranges changed: base

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
google-oauth2.cabal view
@@ -1,82 +1,61 @@-Name:                   google-oauth2-Version:                0.2.2-Author:                 Pat Brisbin <pbrisbin@gmail.com>-Maintainer:             Pat Brisbin <pbrisbin@gmail.com>-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 <pbrisbin@gmail.com>+maintainer:     Pat Brisbin <pbrisbin@gmail.com>+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
src/Network/Google/OAuth2.hs view
@@ -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
+ test/Network/Google/OAuth2Spec.hs view
@@ -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)+    ]