hoauth2 0.2.6 → 0.3.0
raw patch · 7 files changed
+221/−59 lines, 7 filesdep ~conduitdep ~http-conduitdep ~resourcetPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: conduit, http-conduit, resourcet
API changes (from Hackage documentation)
Files
- example/Github/test.hs +59/−0
- example/Google/test.hs +104/−49
- example/Keys.hs.sample +40/−0
- example/Weibo/test.hs +6/−6
- example/run-7.4.sh +2/−0
- example/run.sh +2/−0
- hoauth2.cabal +8/−4
+ example/Github/test.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Github API: http://developer.github.com/v3/oauth/++module Main where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.Maybe (fromJust)+import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types as HT+import Network.HTTP.Conduit+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Conduit (MonadResource)+import Control.Applicative+import Control.Monad (mzero)+import Data.Aeson++import Network.OAuth.OAuth2.HttpClient+import Network.OAuth.OAuth2++import Keys+++main :: IO ()+main = do+ let state = "testGithubApi"+ print $ (authorizationUrl githubKey) `appendQueryParam` [("state", state)]+ putStrLn "visit the url and paste code here: "+ code <- getLine+ let (url, body) = accessTokenUrl githubKey (sToBS code)+ token <- doJSONPostRequest (url, body ++ [("state", state)])+ print (token :: Maybe AccessToken)+ case token of+ Just (AccessToken t _) -> userInfo (githubKey {oauthAccessToken = Just t}) >>= print+ _ -> print "no access token found yet"++sToBS :: String -> BS.ByteString+sToBS = T.encodeUtf8 . T.pack++-- | Test API: user+--+userInfo :: OAuth2 -> IO (Maybe GithubUser)+userInfo oauth = doJSONGetRequest (appendAccessToken+ "https://api.github.com/user"+ oauth)++data GithubUser = GithubUser { gid :: Integer+ , gname :: Text+ } deriving (Show, Eq)++instance FromJSON GithubUser where+ parseJSON (Object o) = GithubUser+ <$> o .: "id"+ <*> o .: "name"+ parseJSON _ = mzero
example/Google/test.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} {- This is basically very manual test. Check following link for details. -google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer+Google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer Google OAuth 2.0 playround: https://developers.google.com/oauthplayground/ @@ -12,74 +12,129 @@ module Main where -import qualified Data.ByteString.Char8 as BS-import Data.Maybe (fromJust)-import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery)-import System.Environment- import Network.OAuth.OAuth2.HttpClient import Network.OAuth.OAuth2-import Google.Key+import Keys (googleKey) +import Control.Applicative ((<$>), (<*>))+import Control.Monad (mzero)+import Data.Aeson (FromJSON, Value(Object), parseJSON, (.:), (.:?))+import Data.Aeson.TH (deriveJSON)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Internal as BL+import Data.Text (Text)+import Prelude hiding (id)+import qualified Prelude as P (id)+import System.Environment (getArgs) -------------------------------------------------- +data Token = Token { issued_to :: Text+ , audience :: Text+ , user_id :: Maybe Text+ , scope :: Text+ , expires_in :: Integer+ , email :: Maybe Text+ , verified_email :: Maybe Bool+ , access_type :: Text+ } deriving (Show)++instance FromJSON Token where+ parseJSON (Object o) = Token+ <$> o .: "issued_to"+ <*> o .: "audience"+ <*> o .:? "user_id"+ <*> o .: "scope"+ <*> o .: "expires_in"+ <*> o .:? "email"+ <*> o .:? "verified_email"+ <*> o .: "access_type"+ parseJSON _ = mzero++data User = User { id :: Text+ , name :: Text+ , given_name :: Text+ , family_name :: Text+ , link :: Text+ , picture :: Text+ , gender :: Text+ , birthday :: Text+ , locale :: Text+ } deriving (Show)++$(deriveJSON P.id ''User)++--------------------------------------------------+ main :: IO () main = do- (x:_) <- getArgs- case x of- "normal" -> normalCase- "offline" -> offlineCase-+ xs <- getArgs+ case xs of+ ["offline"] -> offlineCase+ _ -> normalCase offlineCase :: IO ()-offlineCase = do - print $ authorizationUrl googleKeys `BS.append` "&" `BS.append` extraParams- putStrLn "visit the url and paste code here: "- code <- getLine- (Just (AccessToken accessToken refreshToken)) <- requestAccessToken googleKeys (BS.pack code) - print (accessToken, refreshToken)- validateToken accessToken >>= print- -- - -- obtain a new access token with refresh token, which turns out only in response at first time.- -- Revoke Access https://www.google.com/settings/security- --- case refreshToken of- Nothing -> print "Failed to fetch refresh token"- Just tk -> refreshAccessToken googleKeys tk >>= print- where extraParams = renderSimpleQuery False $ ("access_type", "offline"):googleScopeEmail-+offlineCase = do+ print $ authorizationUrl googleKey `appendQueryParam'` googleScopeEmail `appendQueryParam'` googleAccessOffline+ putStrLn "visit the url and paste code here: "+ code <- fmap BS.pack getLine+ (Just (AccessToken accessToken refreshToken)) <- requestAccessToken googleKey code+ print (accessToken, refreshToken)+ validateToken accessToken >>= print+ (validateToken' accessToken :: IO (Maybe Token)) >>= print+ --+ -- obtain a new access token with refresh token, which turns out only in response at first time.+ -- Revoke Access https://www.google.com/settings/security+ --+ case refreshToken of+ Nothing -> print "Failed to fetch refresh token"+ Just tk -> do+ (Just (AccessToken accessToken refreshToken)) <- refreshAccessToken googleKey tk+ print (accessToken, refreshToken)+ validateToken accessToken >>= print+ (validateToken' accessToken :: IO (Maybe Token)) >>= print normalCase :: IO ()-normalCase = do - print $ authorizationUrl googleKeys `BS.append` "&" `BS.append` extraParams- putStrLn "visit the url and paste code here: "- code <- getLine- (Just (AccessToken accessToken Nothing)) <- requestAccessToken googleKeys (BS.pack code) - print accessToken- res <- validateToken accessToken- print res- res2 <- userinfo accessToken- print res2- where extraParams = renderSimpleQuery False googleScopeEmail-+normalCase = do+ print $ authorizationUrl googleKey `appendQueryParam'` googleScopeUserInfo+ putStrLn "visit the url and paste code here: "+ code <- fmap BS.pack getLine+ (Just (AccessToken accessToken Nothing)) <- requestAccessToken googleKey code+ putStr "AccessToken: " >> print accessToken+ validateToken accessToken >>= print+ (validateToken' accessToken :: IO (Maybe Token)) >>= print+ userinfo accessToken >>= print+ (userinfo' accessToken :: IO (Maybe User)) >>= print -------------------------------------------------- -- Google API --- | this is special for google Gain read-only access to the user's email address.+-- | This is special for google Gain read-only access to the user's email address.+googleScopeEmail :: QueryParams googleScopeEmail = [("scope", "https://www.googleapis.com/auth/userinfo.email")] --- | Gain read-only access to basic profile information, including a +-- | Gain read-only access to basic profile information, including a+googleScopeUserInfo :: QueryParams googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")] --- Token Validation-validateToken accessToken = doSimplePostRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo", - (accessTokenToParam accessToken))+-- | Access offline+googleAccessOffline :: QueryParams+googleAccessOffline = [("access_type", "offline")+ ,("approval_prompt", "force")] +-- | Token Validation+validateToken :: BS.ByteString -> IO BL.ByteString+validateToken accessToken = doSimpleGetRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo" `appendQueryParam` (accessTokenToParam accessToken))++validateToken' :: FromJSON a => BS.ByteString -> IO (Maybe a)+validateToken' accessToken = doJSONGetRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo" `appendQueryParam` (accessTokenToParam accessToken))+ -- | fetch user email. -- for more information, please check the playround site. ---userinfo accessToken = doSimpleGetRequest (appendQueryParam- "https://www.googleapis.com/oauth2/v2/userinfo"- (accessTokenToParam accessToken))+userinfo :: BS.ByteString -> IO BL.ByteString+userinfo accessToken = doSimpleGetRequest ("https://www.googleapis.com/oauth2/v2/userinfo" `appendQueryParam` (accessTokenToParam accessToken))++userinfo' :: FromJSON a => BS.ByteString -> IO (Maybe a)+userinfo' accessToken = doJSONGetRequest ("https://www.googleapis.com/oauth2/v2/userinfo" `appendQueryParam` (accessTokenToParam accessToken))+
+ example/Keys.hs.sample view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module Keys where++import Network.OAuth.OAuth2++weiboKey :: OAuth2+weiboKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"+ , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just "http://127.0.0.1:9988/oauthCallback"+ , oauthOAuthorizeEndpoint = ""+ , oauthAccessTokenEndpoint = ""+ , oauthAccessToken = Nothing+ }++githubKeys :: OAuth2+githubKeys = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"+ , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just "http://127.0.0.1:9988/oauthCallback"+ , oauthOAuthorizeEndpoint = "http://developer.github.com/v3/oauth/"+ , oauthAccessTokenEndpoint = "http://developer.github.com/v3/oauth/"+ , oauthAccessToken = Nothing+ }++googleKey :: OAuth2+googleKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx.apps.googleusercontent.com"+ , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just "https://developers.google.com/oauthplayground"+ , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth"+ , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token"+ , oauthAccessToken = Nothing}++facebookKey :: OAuth2+facebookKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"+ , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just "https://developers.facebook.com/tools/debug"+ , oauthOAuthorizeEndpoint = "https://www.facebook.com/dialog/oauth"+ , oauthAccessTokenEndpoint = "https://graph.facebook.com/oauth/access_token"+ , oauthAccessToken = Nothing}+
example/Weibo/test.hs view
@@ -13,7 +13,7 @@ 4. copy the `code` in the callback url and parse into console 5. this test case will gain access token using the `code` and print it out. -check for integration testing at: +check for integration testing at: https://github.com/HaskellCNOrg/snaplet-oauth/tree/master/test -}@@ -33,14 +33,14 @@ import Network.OAuth.OAuth2.HttpClient import Network.OAuth.OAuth2 -import Weibo.Key- +import Keys+ main :: IO ()-main = do - print $ authorizationUrl weiboKeys+main = do+ print $ authorizationUrl weiboKey putStrLn "visit the url and paste code here: " code <- getLine- token <- requestAccessToken weiboKeys (sToBS code)+ token <- requestAccessToken weiboKey (sToBS code) print token sToBS :: String -> BS.ByteString
+ example/run-7.4.sh view
@@ -0,0 +1,2 @@+runghc -package-conf=../cabal-dev/packages-7.4.1.conf $*+
+ example/run.sh view
@@ -0,0 +1,2 @@+runghc -package-db=../cabal-dev/packages-7.6.1.conf $*+
hoauth2.cabal view
@@ -1,6 +1,6 @@ Name: hoauth2 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy)-Version: 0.2.6+Version: 0.3.0 Synopsis: hoauth2 Description:@@ -30,6 +30,10 @@ README.md example/Google/test.hs example/Weibo/test.hs+ example/Github/test.hs+ example/Keys.hs.sample+ example/run-7.4.sh+ example/run.sh Cabal-version: >=1.8 @@ -50,13 +54,13 @@ text >= 0.11 && < 0.12, bytestring >= 0.9 && < 0.11, bytestring-show >= 0.3.5 && < 0.4,- conduit >= 0.5 && < 0.6,- http-conduit >= 1.8.4 && < 1.8.5,+ conduit >= 1.0 && < 1.1,+ http-conduit >= 1.9 && < 1.10, http-types >= 0.7 && < 0.8, monad-control >= 0.3 && < 0.4, mtl >= 1 && < 2.2, transformers >= 0.2 && < 0.4,- resourcet >= 0.4.0.2 && < 0.4.1,+ resourcet >= 0.4.5 && < 0.4.6, random if impl(ghc >= 6.12.0)