hoauth2 0.3.0 → 0.3.5

raw patch · 12 files changed

+461/−368 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• example/Facebook/test.hs +59/−0
• example/Github/test.hs +27/−28
• example/Google/test.hs +64/−57
• example/Keys.hs.sample +17/−17
• example/Weibo/test.hs +19/−14
• example/run-7.4.sh +0/−2
• example/run-7.6.sh +2/−0
• example/run.sh +1/−1
• hoauth2.cabal +7/−3
• src/Network/OAuth/OAuth2.hs +7/−158
• src/Network/OAuth/OAuth2/HttpClient.hs +111/−88
• src/Network/OAuth/OAuth2/Internal.hs +147/−0

@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++{- Facebook example -}++module Main where++import           Keys                            (facebookKey)+import           Network.OAuth.OAuth2+import           Network.OAuth.OAuth2.HttpClient++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.Char8      as BL+import           Data.Text                       (Text)+import           Prelude                         hiding (id)+import qualified Prelude                         as P (id)+import           System.Environment              (getArgs)++--------------------------------------------------++data User = User { id    :: Text+                 , name  :: Text+                 , email :: Text+                 } deriving (Show)++$(deriveJSON P.id ''User)++--------------------------------------------------++main :: IO ()+main = do+    print $ authorizationUrl facebookKey `appendQueryParam` facebookScope+    putStrLn "visit the url and paste code here: "+    code <- fmap BS.pack getLine+    let (url, body) = accessTokenUrl facebookKey code+    (Right token) <- doJSONPostRequest url (body ++ [("state", "test")])+    userinfo token >>= print+    userinfo' token >>= print++--------------------------------------------------+-- FaceBook API++-- | Gain read-only access to the user's id, name and email address.+facebookScope :: QueryParams+facebookScope = [("scope", "user_about_me,email")]++-- | Fetch user id and email.+userinfo :: AccessToken -> IO (OAuth2Result BL.ByteString)+userinfo token = authGetJSON token "https://graph.facebook.com/me?fields=id,name,email&"++userinfo' :: FromJSON User => AccessToken -> IO (OAuth2Result User)+userinfo' token = authGetJSON token "https://graph.facebook.com/me?fields=id,name,email"+

@@ -1,55 +1,51 @@+{-# LANGUAGE FlexibleContexts  #-} {-# 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           Control.Monad                   (mzero)+import           Control.Monad.Trans.Control     (MonadBaseControl) import           Data.Aeson+import qualified Data.ByteString                 as BS+import qualified Data.ByteString.Lazy.Char8      as BSL+import           Data.Conduit                    (MonadResource)+import           Data.Maybe                      (fromJust)+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import qualified Data.Text.Encoding              as T+import           Network.HTTP.Conduit+import qualified Network.HTTP.Types              as HT -import Network.OAuth.OAuth2.HttpClient-import Network.OAuth.OAuth2+import           Network.OAuth.OAuth2+import           Network.OAuth.OAuth2.HttpClient -import Keys+import           Keys   main :: IO () main = do     let state = "testGithubApi"-    print $ (authorizationUrl githubKey) `appendQueryParam` [("state", state)]+    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)+    token <- doJSONPostRequest url (body ++ [("state", state)])+    print (token :: OAuth2Result AccessToken)     case token of-      Just (AccessToken t _) -> userInfo (githubKey {oauthAccessToken = Just t}) >>= print-      _      -> print "no access token found yet"+      Right at  -> userInfo at >>= print+      Left l    -> 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)+userInfo :: AccessToken -> IO (OAuth2Result GithubUser)+userInfo token = authGetJSON token "https://api.github.com/user" -data GithubUser = GithubUser { gid    :: Integer-                             , gname  :: Text+data GithubUser = GithubUser { gid   :: Integer+                             , gname :: Text                              } deriving (Show, Eq)  instance FromJSON GithubUser where@@ -57,3 +53,6 @@                            <$> o .: "id"                            <*> o .: "name"     parseJSON _ = mzero++sToBS :: String -> BS.ByteString+sToBS = T.encodeUtf8 . T.pack

@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}  {- @@ -12,45 +13,49 @@  module Main where -import Network.OAuth.OAuth2.HttpClient-import Network.OAuth.OAuth2-import Keys (googleKey)+import           Keys                            (googleKey)+import           Network.OAuth.OAuth2+import           Network.OAuth.OAuth2.HttpClient -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)+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           Network.HTTP.Types              (renderSimpleQuery)+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+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+                   , 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+-- ance 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 +$(deriveJSON P.id ''Token)+ data User = User { id          :: Text                  , name        :: Text                  , given_name  :: Text@@ -75,36 +80,38 @@  offlineCase :: IO () offlineCase = do-    print $ authorizationUrl googleKey `appendQueryParam'` googleScopeEmail `appendQueryParam'` googleAccessOffline+    print $ authorizationUrl googleKey `appendQueryParam` (googleScopeEmail ++ 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+    (Right token) <- fetchAccessToken googleKey code+    f token     --     -- 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+    case refreshToken token 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+            (Right token) <- fetchAccessToken googleKey tk+            f token+            --validateToken accessToken >>= print+            --(validateToken' accessToken :: IO (OAuth2Result Token)) >>= print+    where f token = do+            print token+            validateToken token >>= print+            (validateToken' token :: IO (OAuth2Result Token)) >>= print  normalCase :: IO () normalCase = do-    print $ authorizationUrl googleKey `appendQueryParam'` googleScopeUserInfo+    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+    (Right token) <- fetchAccessToken googleKey code+    putStr "AccessToken: " >> print token+    validateToken token >>= print+    (validateToken' token :: IO (OAuth2Result Token)) >>= print+    userinfo token >>= print+    (userinfo' token :: IO (OAuth2Result User)) >>= print  -------------------------------------------------- -- Google API@@ -123,18 +130,18 @@                       ,("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 :: AccessToken -> IO (OAuth2Result BL.ByteString)+validateToken token = authGetJSON token "https://www.googleapis.com/oauth2/v1/tokeninfo" -validateToken' :: FromJSON a => BS.ByteString -> IO (Maybe a)-validateToken' accessToken = doJSONGetRequest ("https://www.googleapis.com/oauth2/v1/tokeninfo" `appendQueryParam` (accessTokenToParam accessToken))+validateToken' :: FromJSON a => AccessToken -> IO (OAuth2Result a)+validateToken' token = authGetJSON token "https://www.googleapis.com/oauth2/v1/tokeninfo"  -- | fetch user email. --   for more information, please check the playround site. ---userinfo :: BS.ByteString -> IO BL.ByteString-userinfo accessToken = doSimpleGetRequest ("https://www.googleapis.com/oauth2/v2/userinfo" `appendQueryParam` (accessTokenToParam accessToken))+userinfo :: AccessToken -> IO (OAuth2Result BL.ByteString)+userinfo token = authGetJSON token "https://www.googleapis.com/oauth2/v2/userinfo" -userinfo' :: FromJSON a => BS.ByteString -> IO (Maybe a)-userinfo' accessToken = doJSONGetRequest ("https://www.googleapis.com/oauth2/v2/userinfo" `appendQueryParam` (accessTokenToParam accessToken))+userinfo' :: FromJSON a => AccessToken -> IO (OAuth2Result a)+userinfo' token = authGetJSON token "https://www.googleapis.com/oauth2/v2/userinfo" 

@@ -2,39 +2,39 @@  module Keys where -import Network.OAuth.OAuth2+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+                   , oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/authorize"+                   , oauthAccessTokenEndpoint = "https://api.weibo.com/oauth2/access_token"                    } +-- | http://developer.github.com/v3/oauth/ 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+                    , oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize"+                    , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"                     } +-- | oauthCallback = Just "https://developers.google.com/oauthplayground" 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}+                   , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"+                   , oauthCallback = Just "http://127.0.0.1:9988/googleCallback"+                   , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth"+                   , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token"+                   }  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}+                     , 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"+                     } 

@@ -1,5 +1,5 @@+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}  {- @@ -20,28 +20,33 @@  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 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.Monad.Trans.Control     (MonadBaseControl)+import qualified Data.ByteString                 as BS+import qualified Data.ByteString.Lazy.Char8      as BSL+import           Data.Conduit                    (MonadResource)+import           Data.Maybe                      (fromJust)+import qualified Data.Text                       as T+import qualified Data.Text.Encoding              as T+import           Network.HTTP.Conduit+import qualified Network.HTTP.Types              as HT -import Network.OAuth.OAuth2.HttpClient-import Network.OAuth.OAuth2+import           Network.OAuth.OAuth2+import           Network.OAuth.OAuth2.HttpClient -import Keys+import           Keys  main :: IO () main = do           print $ authorizationUrl weiboKey           putStrLn "visit the url and paste code here: "           code <- getLine-          token <- requestAccessToken weiboKey (sToBS code)+          token <- fetchAccessToken weiboKey (sToBS code)           print token+          case token of+            Right r -> do+                       uid <- authGetBS r "https://api.weibo.com/2/account/get_uid.json"+                       print uid+            Left l -> BSL.putStrLn l  sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack

@@ -1,2 +0,0 @@-runghc -package-conf=../cabal-dev/packages-7.4.1.conf $*-

@@ -0,0 +1,2 @@+runghc -package-db=../cabal-dev/packages-7.6.1.conf $*+

@@ -1,2 +1,2 @@-runghc -package-db=../cabal-dev/packages-7.6.1.conf $*+runghc -package-conf=../cabal-dev/packages-7.4.1.conf $* 

@@ -1,6 +1,6 @@ Name:                hoauth2 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy)-Version:             0.3.0+Version:             0.3.5  Synopsis:            hoauth2 Description:@@ -11,6 +11,8 @@   * google web oauth: <https://developers.google.com/accounts/docs/OAuth2WebServer>   .   * weibo oauth2: <http://open.weibo.com/wiki/Oauth2>+  .+  * github oauth: <http://developer.github.com/v3/oauth/>  Homepage:            https://github.com/freizl/hoauth2 License:             BSD3@@ -21,7 +23,7 @@ Category:            Network Build-type:          Simple stability:           alpha-tested-with:         GHC <= 7.6.1+tested-with:         GHC <= 7.6.3   -- Extra files to be distributed with the package, such as examples or@@ -31,8 +33,9 @@   example/Google/test.hs   example/Weibo/test.hs   example/Github/test.hs+  example/Facebook/test.hs   example/Keys.hs.sample-  example/run-7.4.sh+  example/run-7.6.sh   example/run.sh  Cabal-version:       >=1.8@@ -46,6 +49,7 @@   hs-source-dirs: src   Exposed-modules:     Network.OAuth.OAuth2.HttpClient+    Network.OAuth.OAuth2.Internal     Network.OAuth.OAuth2    Build-Depends:

@@ -1,159 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}---- | A simple OAuth2 Haskell binding.---   (This is supposed to be independent with http client.)--module Network.OAuth.OAuth2 where--import           Control.Applicative ((<$>), (<*>))-import           Control.Exception-import           Control.Monad       (mzero)-import           Data.Aeson-import qualified Data.ByteString     as BS-import           Data.Maybe          (fromMaybe)-import           Data.Typeable       (Typeable)-import           Network.HTTP.Types  (renderSimpleQuery)------------------------------------------------------- Data Types------------------------------------------------------- | Query Parameter Representation----data OAuth2 = OAuth2 { oauthClientId            :: BS.ByteString-                     , oauthClientSecret        :: BS.ByteString-                     , oauthOAuthorizeEndpoint  :: BS.ByteString-                     , oauthAccessTokenEndpoint :: BS.ByteString-                     , oauthCallback            :: Maybe BS.ByteString-                     , oauthAccessToken         :: Maybe BS.ByteString-                       -- ^ TODO: why not Maybe AccessToken???-                     } deriving (Show, Eq)---- | Simple Exception representation.-data OAuthException = OAuthException String-                      deriving (Show, Eq, Typeable)---- | OAuthException is kind of Exception.----instance Exception OAuthException---- | The gained Access Token. Use @Data.Aeson.decode@ to decode string to @AccessToken@.---   The @refresheToken@ is special at some case.---   e.g. https://developers.google.com/accounts/docs/OAuth2----data AccessToken = AccessToken { accessToken  :: BS.ByteString-                               , refreshToken :: Maybe BS.ByteString }-                   deriving (Show)---- | Parse JSON data into {AccessToken}----instance FromJSON AccessToken where-    parseJSON (Object o) = AccessToken-                           <$> o .: "access_token"-                           <*> o .:? "refresh_token"-    parseJSON _ = mzero------------------------------------------------------- Types Synonym------------------------------------------------------- | type synonym of query parameters-type QueryParams = [(BS.ByteString, BS.ByteString)]---- | type synonym of post body content-type PostBody = [(BS.ByteString, BS.ByteString)]---- | type synonym of a URI-type URI = BS.ByteString---- | Access Code that is required for fetching Access Token-type AccessCode = BS.ByteString-------------------------------------------------------- URLs------------------------------------------------------- | Prepare the authorization URL.---   Redirect to this URL asking for user interactive authentication.----authorizationUrl :: OAuth2 -> URI-authorizationUrl oa = oauthOAuthorizeEndpoint oa `appendQueryParam` queryStr-  where queryStr = transform' [ ("client_id", Just $ oauthClientId oa)-                              , ("response_type", Just "code")-                              , ("redirect_uri", oauthCallback oa)]----- | Prepare URL and the request body query for fetching access token.----accessTokenUrl :: OAuth2-                  -> AccessCode       -- ^ access code gained via authorization URL-                  -> (URI, PostBody)  -- ^ access token request URL plus the request body.-accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code")---accessTokenUrl' ::  OAuth2-                    -> AccessCode            -- ^ access code gained via authorization URL-                    -> Maybe BS.ByteString   -- ^ Grant Type-                    -> (URI, PostBody)       -- ^ access token request URL plus the request body.-accessTokenUrl' oa code gt = (uri, body)-  where uri  = oauthAccessTokenEndpoint oa-        body = transform' [ ("client_id", Just $ oauthClientId oa)-                          , ("client_secret", Just $ oauthClientSecret oa)-                          , ("code", Just code)-                          , ("redirect_uri", oauthCallback oa)-                          , ("grant_type", gt) ]---- | Using a Refresh Token.---   obtain a new access token by sending a refresh token to the Authorization server.----refreshAccessTokenUrl :: OAuth2-                         -> BS.ByteString    -- ^ refresh token gained via authorization URL-                         -> (URI, PostBody)  -- ^ refresh token request URL plus the request body.-refreshAccessTokenUrl oa rtoken = (uri, body)-  where uri = oauthAccessTokenEndpoint oa-        body = transform' [ ("client_id", Just $ oauthClientId oa)-                          , ("client_secret", Just $ oauthClientSecret oa)-                          , ("grant_type", Just "refresh_token")-                          , ("refresh_token", Just rtoken) ]------------------------------------------------------- UTILs------------------------------------------------------- | Append query parameters with '?'-appendQueryParam :: URI -> QueryParams -> URI-appendQueryParam uri q = uri `BS.append` renderSimpleQuery True q---- | Append query parameters with '&'.-appendQueryParam' :: URI -> QueryParams -> URI-appendQueryParam' uri q = uri `BS.append` "&" `BS.append` renderSimpleQuery False q---- | For GET method API.-appendAccessToken :: URI   -- ^ Base URI-          -> OAuth2        -- ^ OAuth has Authorized Access Token-          -> URI           -- ^ Combined Result-appendAccessToken uri oauth = appendQueryParam uri-                              (token $ oauthAccessToken oauth)-                              where token :: Maybe BS.ByteString -> QueryParams-                                    token = accessTokenToParam . fromMaybe ""---- | Create QueryParams with given access token value.----accessTokenToParam :: BS.ByteString -> QueryParams-accessTokenToParam token = [("access_token", token)]----- | lift value in the Maybe and abonda Nothing-transform' :: [(a, Maybe b)] -> [(a, b)]-transform' = foldr step' []-             where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)]-                   step' (a, Just b) xs = (a, b):xs-                   step' _ xs = xs---                        -- Expect Access Token exists-                        -- FIXME: append empty when Nothing-  --uri `BS.append` renderSimpleQuery True (accessTokenToParam $ token oauth)+module Network.OAuth.OAuth2+       (module Network.OAuth.OAuth2.HttpClient,+        module Network.OAuth.OAuth2.Internal+       )+       where +import           Network.OAuth.OAuth2.HttpClient+import           Network.OAuth.OAuth2.Internal

@@ -2,127 +2,150 @@ {-# LANGUAGE FlexibleContexts   #-} {-# LANGUAGE OverloadedStrings  #-} --- | A simple http client for request OAuth2 tokens and several utils.+-- | A simple http client to request OAuth2 tokens and several utils.  module Network.OAuth.OAuth2.HttpClient where -import           Control.Exception-import           Control.Monad                (liftM)-import           Control.Monad.Trans.Resource (ResourceT)+import           Control.Monad                 (liftM)+import           Control.Monad.Trans.Resource  (ResourceT) import           Data.Aeson-import qualified Data.ByteString              as BS-import qualified Data.ByteString.Lazy.Char8   as BSL-import qualified Data.Text                    as T-import qualified Data.Text.Encoding           as T+import qualified Data.ByteString.Char8         as BS+import qualified Data.ByteString.Lazy.Char8    as BSL+import           Data.Maybe import           Network.HTTP.Conduit-import           Network.HTTP.Types           (renderSimpleQuery)-import qualified Network.HTTP.Types           as HT+import qualified Network.HTTP.Types            as HT -import           Network.OAuth.OAuth2+import           Network.OAuth.OAuth2.Internal  ----------------------------------------------------- Fetch AccessToken; RefreshAccessToken+-- * Retrieve access token --------------------------------------------------  -- | Request (via POST method) "Access Token". -----   FIXME: what if @requestAccessToken'@ return error? ---requestAccessToken :: OAuth2                 -- ^ OAuth Data-                   -> BS.ByteString          -- ^ Authentication code gained after authorization-                   -> IO (Maybe AccessToken) -- ^ Access Token-requestAccessToken oa code = doJSONPostRequest (accessTokenUrl oa code)+fetchAccessToken :: OAuth2                           -- ^ OAuth Data+                   -> BS.ByteString                  -- ^ Authentication code gained after authorization+                   -> IO (OAuth2Result AccessToken)  -- ^ Access Token+fetchAccessToken oa code = doJSONPostRequest uri body+                           where (uri, body) = accessTokenUrl oa code   -- | Request the "Refresh Token".----refreshAccessToken :: OAuth2-                   -> BS.ByteString          -- ^ refresh token gained after authorization-                   -> IO (Maybe AccessToken)-refreshAccessToken oa rtoken = doJSONPostRequest (refreshAccessTokenUrl oa rtoken)+fetchRefreshToken :: OAuth2                          -- ^ OAuth context+                     -> BS.ByteString                -- ^ refresh token gained after authorization+                     -> IO (OAuth2Result AccessToken)+fetchRefreshToken oa rtoken = doJSONPostRequest uri body+                              where (uri, body) = refreshAccessTokenUrl oa rtoken  ------------------------------------------------------ conduit http request------------------------------------------------------- | Conduct post request.----doSimplePostRequest :: (URI, PostBody)       -- ^ The URI and request body for fetching token.-                       -> IO BSL.ByteString  -- ^ Response as ByteString-doSimplePostRequest (uri, body) = doPostRequst (bsToS uri) body >>= handleResponse- -- | Conduct post request and return response as JSON.--- doJSONPostRequest :: FromJSON a-                     => (URI, PostBody)  -- ^ The URI and request body for fetching token.-                     -> IO (Maybe a)     -- ^ Response as ByteString-doJSONPostRequest (uri, body) = doPostRequst (bsToS uri) body-                                >>= liftM decode . handleResponse+                  => URI                                 -- ^ The URL+                  -> PostBody                            -- ^ request body+                  -> IO (OAuth2Result a)                 -- ^ Response as ByteString+doJSONPostRequest uri body = liftM parseResponseJSON (doSimplePostRequest uri body) --- | Conduct GET request.----doSimpleGetRequest :: URI                           -- ^ URL-                      -> IO BSL.ByteString  -- ^ Response as ByteString-doSimpleGetRequest url = doGetRequest (bsToS url) [] >>= handleResponse+-- | Conduct post request.+doSimplePostRequest :: URI                                  -- ^ URL+                       -> PostBody                          -- ^ Request body.+                       -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString+doSimplePostRequest url body = liftM handleResponse go+                               where go = do+                                          req <- parseUrl $ BS.unpack url+                                          let req' = updateRequestHeaders Nothing req+                                          withManager $ httpLbs (urlEncodedBody body req') +--------------------------------------------------+-- * AUTH requests+--------------------------------------------------+ -- | Conduct GET request and return response as JSON.----doJSONGetRequest :: FromJSON a-                    => URI         -- ^ Full URL-                    -> IO (Maybe a)   -- ^ Response as ByteString-doJSONGetRequest url = doGetRequest (bsToS url) []-                       >>= liftM decode . handleResponse+authGetJSON :: FromJSON a+                 => AccessToken+                 -> URI                          -- ^ Full URL+                 -> IO (OAuth2Result a)          -- ^ Response as JSON+authGetJSON t uri = liftM parseResponseJSON $ authGetBS t uri +-- | Conduct GET request.+authGetBS :: AccessToken+             -> URI                               -- ^ URL+             -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString+authGetBS token url = liftM handleResponse go+                      where go = do+                                 req <- parseUrl $ BS.unpack $ url `appendAccessToken` token+                                 authenticatedRequest token HT.GET req --- | Conduct GET request with given URL by append extra parameters provided.----doGetRequest :: String                               -- ^ URL-                -> [(BS.ByteString, BS.ByteString)]  -- ^ Extra Parameters-                -> IO (Response BSL.ByteString)      -- ^ Response-doGetRequest url pm = doGetRequestWithReq url pm id+-- | Conduct POST request and return response as JSON.+authPostJSON :: FromJSON a+                 => AccessToken+                 -> URI                          -- ^ Full URL+                 -> PostBody+                 -> IO (OAuth2Result a)          -- ^ Response as JSON+authPostJSON t uri pb = liftM parseResponseJSON $ authPostBS t uri pb --- | TODO: can not be `Request m -> Request m`, why??----doGetRequestWithReq :: String                               -- ^ URL-                       -> [(BS.ByteString, BS.ByteString)]  -- ^ Extra Parameters-                       -> (Request (ResourceT IO) -> Request (ResourceT IO))          -- ^ update Request-                       -> IO (Response BSL.ByteString)      -- ^ Response-doGetRequestWithReq url pm f = do-    req <- parseUrl $ url ++ bsToS (renderSimpleQuery True pm)-    let req' = (updateRequestHeaders .f) req-    withManager $ httpLbs req'+-- | Conduct POST request.+authPostBS :: AccessToken+             -> URI                               -- ^ URL+             -> PostBody+             -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString+authPostBS token url pb = liftM handleResponse go+                          where body = pb ++ accessTokenToParam token+                                go = do+                                     req <- parseUrl $ BS.unpack url+                                     authenticatedRequest token HT.POST $  urlEncodedBody body req  --- | Conduct POST request with given URL with post body data.+-- |Sends a HTTP request including the Authorization header with the specified+--  access token. ---doPostRequst ::  String                               -- ^ URL-                 -> [(BS.ByteString, BS.ByteString)]  -- ^ Data to Post Body-                 -> IO (Response BSL.ByteString)      -- ^ Response-doPostRequst url body = doPostRequstWithReq url body id--doPostRequstWithReq ::  String                               -- ^ URL-                        -> [(BS.ByteString, BS.ByteString)]  -- ^ Data to Post Body-                        -> (Request (ResourceT IO) -> Request (ResourceT IO))-                        -> IO (Response BSL.ByteString)      -- ^ Response-doPostRequstWithReq url body f = do-    req <- parseUrl url-    let req' = (updateRequestHeaders . f) req-    withManager $ httpLbs (urlEncodedBody body req')+authenticatedRequest :: AccessToken             -- ^ Authentication token to use+                     -> HT.StdMethod                     -- ^ Method to use+                     -> Request (ResourceT IO)        -- ^ Request to perform+                     -> IO (Response BSL.ByteString)+authenticatedRequest token m r = withManager+                                 $ httpLbs+                                 $ updateRequestHeaders (Just token)+                                 $ setMethod m r+-- { checkStatus = \_ _ _ -> Nothing } +-- | Sets the HTTP method to use+--+setMethod :: HT.StdMethod -> Request m -> Request m+setMethod m req = req { method = HT.renderStdMethod m }  ----------------------------------------------------- Utils+-- * Utilities -------------------------------------------------- -handleResponse :: Response BSL.ByteString -> IO BSL.ByteString-handleResponse rsp = if (HT.statusCode . responseStatus) rsp == 200-                     then return (responseBody rsp)-                     else throwIO . OAuthException $-                          "Gaining token failed: " ++ BSL.unpack (responseBody rsp)+-- | Parses a @Response@ to to @OAuth2Result@+--+handleResponse :: Response BSL.ByteString -> OAuth2Result BSL.ByteString+handleResponse rsp =+    if HT.statusCode (responseStatus rsp) == 200+        then Right $ responseBody rsp+        else Left $ BSL.append "Gaining token failed: " (responseBody rsp) -updateRequestHeaders :: Request m -> Request m-updateRequestHeaders req = req { requestHeaders = [ (HT.hAccept, "application/json") ] }+-- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@+-- +parseResponseJSON :: FromJSON a+              => OAuth2Result BSL.ByteString+              -> OAuth2Result a+parseResponseJSON (Left b) = Left b+parseResponseJSON (Right b) = case decode b of+                            Nothing -> Left ("Could not decode JSON" `BSL.append` b)+                            Just x -> Right x -bsToS ::  BS.ByteString -> String-bsToS = T.unpack . T.decodeUtf8+-- | set several header values.+--   + userAgennt : hoauth2+--   + accept     : application/json+--   + authorization : Bearer xxxxx  if AccessToken provided.+-- +updateRequestHeaders :: Maybe AccessToken -> Request m -> Request m+updateRequestHeaders t req =+  let extras = [ (HT.hUserAgent, "hoauth2")+               , (HT.hAccept, "application/json") ]+      bearer = [(HT.hAuthorization, "Bearer " `BS.append` (accessToken $ fromJust t)) | isJust t]+      headers = bearer ++ extras ++ requestHeaders req+  in+  req { requestHeaders = headers }

@@ -0,0 +1,147 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}++{-# OPTIONS_HADDOCK -ignore-exports #-}++-- | A simple OAuth2 Haskell binding.+--   (This is supposed to be independent with http client.)++module Network.OAuth.OAuth2.Internal where++import           Control.Applicative  ((<$>), (<*>))+import           Control.Monad        (mzero)+import           Data.Aeson+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BSL+import           Data.Maybe+import           Network.HTTP.Types   (renderSimpleQuery)++--------------------------------------------------+-- * Data Types+--------------------------------------------------++-- | Query Parameter Representation+--+data OAuth2 = OAuth2 {+      oauthClientId            :: BS.ByteString+    , oauthClientSecret        :: BS.ByteString+    , oauthOAuthorizeEndpoint  :: BS.ByteString+    , oauthAccessTokenEndpoint :: BS.ByteString+    , oauthCallback            :: Maybe BS.ByteString+    } deriving (Show, Eq)+++-- | The gained Access Token. Use @Data.Aeson.decode@ to decode string to @AccessToken@.+--   The @refresheToken@ is special at some case.+--   e.g. https://developers.google.com/accounts/docs/OAuth2+--+data AccessToken = AccessToken {+      accessToken  :: BS.ByteString+    , refreshToken :: Maybe BS.ByteString+    } deriving (Show)++-- | Parse JSON data into {AccessToken}+--+instance FromJSON AccessToken where+    parseJSON (Object o) = AccessToken+                           <$> o .: "access_token"+                           <*> o .:? "refresh_token"+    parseJSON _ = mzero++--------------------------------------------------+-- * Types Synonym+--------------------------------------------------++-- | Is either 'Left' containing an error or 'Right' containg a result+--+type OAuth2Result a = Either BSL.ByteString a++-- | type synonym of query parameters+type QueryParams = [(BS.ByteString, BS.ByteString)]++-- | type synonym of post body content+type PostBody = [(BS.ByteString, BS.ByteString)]++-- | type synonym of a URI+type URI = BS.ByteString+++--------------------------------------------------+-- * URLs+--------------------------------------------------++-- | Prepare the authorization URL.+--   Redirect to this URL asking for user interactive authentication.+--+authorizationUrl :: OAuth2 -> URI+authorizationUrl oa = oauthOAuthorizeEndpoint oa `appendQueryParam` queryStr+  where queryStr = transform' [ ("client_id", Just $ oauthClientId oa)+                              , ("response_type", Just "code")+                              , ("redirect_uri", oauthCallback oa)]+++-- | Prepare URL and the request body query for fetching access token.+--+accessTokenUrl :: OAuth2+                  -> BS.ByteString       -- ^ access code gained via authorization URL+                  -> (URI, PostBody)     -- ^ access token request URL plus the request body.+accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code")++accessTokenUrl' ::  OAuth2+                    -> BS.ByteString          -- ^ access code gained via authorization URL+                    -> Maybe BS.ByteString    -- ^ Grant Type+                    -> (URI, PostBody)        -- ^ access token request URL plus the request body.+accessTokenUrl' oa code gt = (uri, body)+  where uri  = oauthAccessTokenEndpoint oa+        body = transform' [ ("client_id", Just $ oauthClientId oa)+                          , ("client_secret", Just $ oauthClientSecret oa)+                          , ("code", Just code)+                          , ("redirect_uri", oauthCallback oa)+                          , ("grant_type", gt) ]++-- | Using a Refresh Token.+--   obtain a new access token by sending a refresh token to the Authorization server.+--+refreshAccessTokenUrl :: OAuth2+                         -> BS.ByteString    -- ^ refresh token gained via authorization URL+                         -> (URI, PostBody)  -- ^ refresh token request URL plus the request body.+refreshAccessTokenUrl oa rtoken = (uri, body)+  where uri = oauthAccessTokenEndpoint oa+        body = transform' [ ("client_id", Just $ oauthClientId oa)+                          , ("client_secret", Just $ oauthClientSecret oa)+                          , ("grant_type", Just "refresh_token")+                          , ("refresh_token", Just rtoken) ]++--------------------------------------------------+-- * UTILs+--------------------------------------------------++-- | Append query parameters with '?'+appendQueryParam :: URI -> QueryParams -> URI+appendQueryParam uri q = if "?" `BS.isInfixOf` uri+                         then uri `BS.append` "&" `BS.append` renderSimpleQuery False q+                         else uri `BS.append` renderSimpleQuery True q++-- | Append query parameters with '&'.+-- appendQueryParam' :: URI -> QueryParams -> URI+-- appendQueryParam' uri q = uri `BS.append` "&" `BS.append` renderSimpleQuery False q+++-- | For GET method API.+appendAccessToken :: URI               -- ^ Base URI+                     -> AccessToken    -- ^ Authorized Access Token+                     -> URI            -- ^ Combined Result+appendAccessToken uri t = appendQueryParam uri (accessTokenToParam t)++-- | Create QueryParams with given access token value.+--+--accessTokenToParam :: BS.ByteString -> QueryParams+--accessTokenToParam token = [("access_token", token)]+accessTokenToParam :: AccessToken -> QueryParams+accessTokenToParam (AccessToken token _) = [("access_token", token)]+++-- | lift value in the Maybe and abonda Nothing+transform' :: [(a, Maybe b)] -> [(a, b)]+transform' = map (\(a, Just b) -> (a, b)) . filter (isJust . snd)+