diff --git a/example/Github/test.hs b/example/Github/test.hs new file mode 100644 --- /dev/null +++ b/example/Github/test.hs @@ -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 diff --git a/example/Google/test.hs b/example/Google/test.hs --- a/example/Google/test.hs +++ b/example/Google/test.hs @@ -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)) + diff --git a/example/Keys.hs.sample b/example/Keys.hs.sample new file mode 100644 --- /dev/null +++ b/example/Keys.hs.sample @@ -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} + diff --git a/example/Weibo/test.hs b/example/Weibo/test.hs --- a/example/Weibo/test.hs +++ b/example/Weibo/test.hs @@ -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 diff --git a/example/run-7.4.sh b/example/run-7.4.sh new file mode 100644 --- /dev/null +++ b/example/run-7.4.sh @@ -0,0 +1,2 @@ +runghc -package-conf=../cabal-dev/packages-7.4.1.conf $* + diff --git a/example/run.sh b/example/run.sh new file mode 100644 --- /dev/null +++ b/example/run.sh @@ -0,0 +1,2 @@ +runghc -package-db=../cabal-dev/packages-7.6.1.conf $* + diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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)