google-oauth2 (empty) → 0.1.0

raw patch · 5 files changed

+308/−0 lines, 5 filesdep +HTTPdep +aesondep +basesetup-changed

Dependencies added: HTTP, aeson, base, bytestring, google-oauth2, hspec, http-conduit, http-types, load-env

Files

LICENSE +19/−0
Setup.hs +2/−0
google-oauth2.cabal +82/−0
src/Network/Google/OAuth2.hs +204/−0
test/Spec.hs +1/−0

+ LICENSE view

@@ -0,0 +1,19 @@+Copyright (c) 2014 Pat Brisbin <pbrisbin@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ google-oauth2.cabal view

@@ -0,0 +1,82 @@+Name:                   google-oauth2+Version:                0.1.0+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 = "..."+  .++Cabal-Version:          >= 1.10+Build-Type:             Simple++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.3+                      , aeson           >= 0.8          && < 0.9+                      , bytestring+                      , http-conduit+  Default-Extensions:   OverloadedStrings+                        RecordWildCards++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++Source-Repository head+  Type:                 git+  Location:             https://github.com/pbrisbin/google-oauth2

+ src/Network/Google/OAuth2.hs view

@@ -0,0 +1,204 @@+module Network.Google.OAuth2+    (+    -- * Types+      OAuth2Client(..)+    , OAuth2Code+    , OAuth2Scope+    , OAuth2Token+    , OAuth2Tokens(..)++    -- * Getting an access token+    , getAccessToken++    -- * Lower-level steps+    , newTokens+    , refreshTokens+    , promptForCode+    , exchangeCode+    ) where++import Control.Arrow (second)+import Control.Applicative ((<$>),(<*>))+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+    , parseUrl+    , withManager+    , urlEncodedBody+    )+import Network.HTTP.Base (urlEncode)+import System.IO (hFlush, stdout)++import qualified Control.Exception as E+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+    }++instance FromJSON RefreshResponse where+    parseJSON (Object o) = RefreshResponse+        <$> o .: "access_token"+        <*> o .: "expires_in"+        <*> o .: "token_type"++    parseJSON _ = mzero++toOAuth2Tokens :: OAuth2Token -> RefreshResponse -> OAuth2Tokens+toOAuth2Tokens token RefreshResponse{..} =+    OAuth2Tokens+        { accessToken = rAccessToken+        , refreshToken = token+        , expiresIn = rExpiresIn+        , tokenType = rTokenType+        }++-- | 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 <- cachedTokens tokenFile+    tokens <- case cached of+        Just t -> return t+        Nothing -> newTokens client scopes++    refreshed <- refreshTokens client tokens+    void $ cacheTokens tokenFile refreshed++    return $ accessToken refreshed++getAccessToken client scopes Nothing = do+    tokens <- newTokens client scopes+    refreshed <- refreshTokens client tokens++    return $ accessToken refreshed++-- | Prompt the user for a verification code and exchange it for tokens+newTokens :: OAuth2Client -> [OAuth2Scope] -> IO OAuth2Tokens+newTokens client scopes = do+    code <- promptForCode client scopes+    tokens <- exchangeCode client code++    return tokens++-- | 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: "+    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+refreshTokens :: OAuth2Client -> OAuth2Tokens -> IO OAuth2Tokens+refreshTokens client tokens = do+    refreshed <- postTokens+        [ ("client_id", clientId client)+        , ("client_secret", clientSecret client)+        , ("grant_type", "refresh_token")+        , ("refresh_token", refreshToken tokens)+        ]++    return $ toOAuth2Tokens (refreshToken tokens) refreshed++postTokens :: FromJSON a => [(ByteString, String)] -> IO a+postTokens params = do+    request <- parseUrl "https://accounts.google.com/o/oauth2/token"++    let params' = map (second C8.pack) params++    fmap unsafeDecode $ withManager $ httpLbs $ urlEncodedBody params' request++cachedTokens :: FilePath -> IO (Maybe OAuth2Tokens)+cachedTokens tokenFile = do+    result <- fmap (fmap reads) $ try $ readFile tokenFile++    return $ case result of+        Right ((t,_):_) -> Just t+        _ -> Nothing++cacheTokens :: FilePath -> OAuth2Tokens -> IO OAuth2Tokens+cacheTokens tokenFile t = fmap (const t) $ try $ writeFile tokenFile (show t)++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)++redirectUri :: String+redirectUri = "urn:ietf:wg:oauth:2.0:oob"++-- 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++try :: IO a -> IO (Either E.IOException a)+try = E.try

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}