hoauth2 0.5.9 → 1.0.0

raw patch · 12 files changed

+395/−284 lines, 12 filesdep +exceptionsdep +microlensdep +uri-bytestringdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, microlens, uri-bytestring

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• example/Douban/test.hs +17/−8
• example/Dropbox/test.hs +10/−13
• example/Facebook/test.hs +18/−10
• example/Fitbit/test.hs +15/−12
• example/Github/test.hs +9/−7
• example/Google/test.hs +52/−40
• example/Keys.hs.sample +26/−24
• example/StackExchange/test.hs +54/−31
• example/Weibo/test.hs +6/−3
• hoauth2.cabal +51/−39
• src/Network/OAuth/OAuth2/HttpClient.hs +36/−29
• src/Network/OAuth/OAuth2/Internal.hs +101/−68

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}  {- @@ -11,29 +12,37 @@  module Main where -import qualified Data.ByteString            as BS+import qualified Data.ByteString.Char8      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.Text.Lazy.Encoding    as TL+import qualified Data.Text.Lazy.IO          as TL import           Network.HTTP.Conduit+import           URI.ByteString+import           URI.ByteString.QQ  import           Network.OAuth.OAuth2 -import           Keys+import           Keys                       (doubanKey)  main :: IO () main = do-  print $ authorizationUrl doubanKey+  BS.putStrLn $ serializeURIRef' $ authorizationUrl doubanKey   putStrLn "visit the url and paste code here: "-  code <- getLine+  code <- fmap (ExchangeToken . T.pack) getLine   mgr <- newManager tlsManagerSettings-  token <- fetchAccessToken mgr doubanKey (sToBS code)+  let (url, body) = accessTokenUrl doubanKey code+  let extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId doubanKey)+                  , ("client_secret", T.encodeUtf8 $ oauthClientSecret doubanKey)+                  ]++  token <- doJSONPostRequest mgr doubanKey url (extraBody ++ body)   print token   case token of     Right r -> do-      -- TODO: display Chinese character. (Text UTF-8 encodeing does not work, why?)-      uid <- authGetBS mgr r "https://api.douban.com/v2/user/~me"-      print uid+      uid <- authGetBS mgr (accessToken r) [uri|https://api.douban.com/v2/user/~me|]+      TL.putStrLn $ either TL.decodeUtf8 TL.decodeUtf8 uid     Left l -> BSL.putStrLn l  sToBS :: String -> BS.ByteString

@@ -1,17 +1,14 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}  module Main where -import           Control.Monad                 (liftM)-import           Data.Aeson.TH         (defaultOptions, deriveJSON)-import qualified Network.HTTP.Types            as HT-import qualified Data.ByteString.Char8 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 qualified Data.Text                  as T import           Network.HTTP.Conduit+import qualified Network.HTTP.Types         as HT+import           URI.ByteString  import           Network.OAuth.OAuth2 @@ -20,15 +17,15 @@  main :: IO () main = do-    print $ authorizationUrl dropboxKey+    BS.putStrLn $ serializeURIRef' $ authorizationUrl dropboxKey     putStrLn "visit the url and paste code here: "-    code <- fmap BS.pack getLine+    code <- getLine     mgr <- newManager tlsManagerSettings-    token <- fetchAccessToken mgr dropboxKey code+    token <- fetchAccessToken mgr dropboxKey (ExchangeToken (T.pack code))     print token     case token of-      Right at  -> getSpaceUsage mgr at >>= print-      Left _    -> putStrLn "no access token found yet"+      Right at -> getSpaceUsage mgr (accessToken at) >>= print+      Left _   -> putStrLn "no access token found yet"  getSpaceUsage :: Manager -> AccessToken -> IO (OAuth2Result BSL.ByteString) getSpaceUsage mgr token = do

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-} {-# LANGUAGE TemplateHaskell   #-}  {- Facebook example -}@@ -11,11 +12,14 @@  import           Data.Aeson                 (FromJSON) import           Data.Aeson.TH              (defaultOptions, deriveJSON)-import qualified Data.ByteString.Char8      as BS import qualified Data.ByteString.Lazy.Char8 as BL import           Data.Text                  (Text)+import qualified Data.Text                  as T+import qualified Data.Text.Encoding         as T import           Network.HTTP.Conduit import           Prelude                    hiding (id)+import           URI.ByteString+import           URI.ByteString.QQ  -------------------------------------------------- @@ -30,17 +34,21 @@  main :: IO () main = do-    print $ authorizationUrl facebookKey `appendQueryParam` facebookScope+    print $ serializeURIRef' $ appendQueryParams  facebookScope $ authorizationUrl facebookKey     putStrLn "visit the url and paste code here: "-    code <- fmap BS.pack getLine+    code <- getLine     mgr <- newManager tlsManagerSettings-    let (url, body) = accessTokenUrl facebookKey code-    resp <- doJSONPostRequest mgr facebookKey url (body ++ [("state", "test")])-    case (resp :: OAuth2Result AccessToken) of+    let (url, body) = accessTokenUrl facebookKey $ ExchangeToken $ T.pack code+    let extraBody = [ ("state", "test")+                    , ("client_id", T.encodeUtf8 $ oauthClientId facebookKey)+                    , ("client_secret", T.encodeUtf8 $ oauthClientSecret facebookKey)+                    ]+    resp <- doJSONPostRequest mgr facebookKey url (body ++ extraBody)+    case (resp :: OAuth2Result OAuth2Token) of       Right token -> do                      print token-                     --userinfo mgr token >>= print-                     userinfo' mgr token >>= print+                     userinfo mgr (accessToken token) >>= print+                     userinfo' mgr (accessToken token) >>= print       Left l -> print l  --------------------------------------------------@@ -52,7 +60,7 @@  -- | Fetch user id and email. userinfo :: Manager -> AccessToken -> IO (OAuth2Result BL.ByteString)-userinfo mgr token = authGetBS mgr token "https://graph.facebook.com/me?fields=id,name,email"+userinfo mgr token = authGetBS mgr token    [uri|https://graph.facebook.com/me?fields=id,name,email|]  userinfo' :: FromJSON User => Manager -> AccessToken -> IO (OAuth2Result User)-userinfo' mgr token = authGetJSON mgr token "https://graph.facebook.com/me?fields=id,name,email"+userinfo' mgr token = authGetJSON mgr token [uri|https://graph.facebook.com/me?fields=id,name,email|]

@@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}  module Main where -import           Control.Applicative import           Control.Monad            (mzero) import           Data.Aeson import qualified Data.ByteString          as B@@ -12,10 +12,13 @@ import qualified Data.Map                 as M import           Data.Text                (Text) import qualified Data.Text                as T+import qualified Data.Text.Encoding       as T import           Network.HTTP.Conduit     hiding (Request, queryString) import           Network.HTTP.Types       (Query, status200) import           Network.Wai import           Network.Wai.Handler.Warp (run)+import           URI.ByteString           (serializeURIRef')+import           URI.ByteString.QQ  import           Keys                     (fitbitKey) import           Network.OAuth.OAuth2@@ -47,7 +50,7 @@  main :: IO () main = do-    print $ authorizationUrl fitbitKey `appendQueryParam` [("state", state), ("scope", "profile")]+    print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey     putStrLn "visit the url to continue"     run 9988 application @@ -67,39 +70,39 @@     mgr <- newManager tlsManagerSettings     token <- getApiToken mgr $ getApiCode request     print token-    user <- getApiUser mgr token+    user <- getApiUser mgr (accessToken token)     print user     return $ encode user -getApiCode :: Request -> B.ByteString+getApiCode :: Request -> ExchangeToken getApiCode request =     case M.lookup "code" queryMap of-        Just code -> code-        Nothing -> error "request doesn't include code"+        Just code -> ExchangeToken $ T.decodeUtf8 code+        Nothing   -> error "request doesn't include code"   where     queryMap = convertQueryToMap $ queryString request -getApiToken :: Manager -> B.ByteString -> IO (AccessToken)+getApiToken :: Manager -> ExchangeToken -> IO OAuth2Token getApiToken mgr code = do     result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)]     case result of         Right token -> return token-        Left e -> error $ lazyBSToString e+        Left e      -> error $ lazyBSToString e   where     (url, body) = accessTokenUrl fitbitKey code -getApiUser :: Manager -> AccessToken -> IO (FitbitUser)+getApiUser :: Manager -> AccessToken -> IO FitbitUser getApiUser mgr token = do-    result <- authGetJSON mgr token "https://api.fitbit.com/1/user/-/profile.json"+    result <- authGetJSON mgr token [uri|https://api.fitbit.com/1/user/-/profile.json|]     case result of         Right user -> return user-        Left e -> error $ lazyBSToString e+        Left e     -> error $ lazyBSToString e  convertQueryToMap :: Query -> M.Map B.ByteString B.ByteString convertQueryToMap query =     M.fromList $ map normalize query   where-    normalize (k, Just v) = (k, v)+    normalize (k, Just v)  = (k, v)     normalize (k, Nothing) = (k, B.empty)  lazyBSToString :: BL.ByteString -> String

@@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}  -- | Github API: http://developer.github.com/v3/oauth/  module Main where -import           Control.Applicative import           Control.Monad        (mzero) import           Data.Aeson import qualified Data.ByteString      as BS@@ -13,6 +13,8 @@ import qualified Data.Text            as T import qualified Data.Text.Encoding   as T import           Network.HTTP.Conduit+import           URI.ByteString+import           URI.ByteString.QQ  import           Network.OAuth.OAuth2 @@ -22,22 +24,22 @@ main :: IO () main = do     let state = "testGithubApi"-    print $ authorizationUrl githubKey `appendQueryParam` [("state", state)]+    print $ serializeURIRef' $ appendQueryParams [("state", state)] $ authorizationUrl githubKey     putStrLn "visit the url and paste code here: "     code <- getLine     mgr <- newManager tlsManagerSettings-    let (url, body) = accessTokenUrl githubKey (sToBS code)+    let (url, body) = accessTokenUrl githubKey $ ExchangeToken $ T.pack code     token <- doJSONPostRequest mgr githubKey url (body ++ [("state", state)])-    print (token :: OAuth2Result AccessToken)+    print (token :: OAuth2Result OAuth2Token)     case token of-      Right at  -> userInfo mgr at >>= print-      Left _    -> putStrLn "no access token found yet"+      Right at -> userInfo mgr (accessToken at) >>= print+      Left _   -> putStrLn "no access token found yet"   -- | Test API: user -- userInfo :: Manager -> AccessToken -> IO (OAuth2Result GithubUser)-userInfo mgr token = authGetJSON mgr token "https://api.github.com/user"+userInfo mgr token = authGetJSON mgr token [uri|https://api.github.com/user|]  data GithubUser = GithubUser { gid   :: Integer                              , gname :: Text

@@ -1,5 +1,6 @@+{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE QuasiQuotes       #-}  {- @@ -13,44 +14,55 @@  module Main where -import           Keys                          (googleKey)-import           Network.OAuth.OAuth2--import           Control.Monad                 (liftM)-import           Data.Aeson                    (FromJSON)-import           Data.Aeson.TH                 (defaultOptions, deriveJSON)+import           Data.Aeson+import           Data.Aeson.Types import qualified Data.ByteString.Char8         as BS import qualified Data.ByteString.Lazy.Internal as BL import           Data.Text                     (Text)+import qualified Data.Text                     as T+import           GHC.Generics import           Network.HTTP.Conduit import           Prelude                       hiding (id) import           System.Environment            (getArgs)+import           URI.ByteString+import           URI.ByteString.QQ +import           Keys                          (googleKey)+import           Network.OAuth.OAuth2+ -------------------------------------------------- -data Token = Token { issued_to   :: Text-                   , audience    :: Text-                   , user_id     :: Maybe Text-                   , scope       :: Text-                   , expires_in  :: Integer-                   , access_type :: Text-                   } deriving (Show)+data Token = Token { issuedTo   :: Text+                   , audience   :: Text+                   , userId     :: Maybe Text+                   , scope      :: Text+                   , expiresIn  :: Integer+                   , accessType :: Text+                   } deriving (Show, Generic)  -$(deriveJSON defaultOptions ''Token)+data User = User { id         :: Text+                 , name       :: Text+                 , givenName  :: Text+                 , familyName :: Text+                 , link       :: Text+                 , picture    :: Text+                 , gender     :: Text+                 , locale     :: Text+                 } deriving (Show, Generic) -data User = User { id          :: Text-                 , name        :: Text-                 , given_name  :: Text-                 , family_name :: Text-                 , link        :: Text-                 , picture     :: Text-                 , gender      :: Text-                 , locale      :: Text-                 } deriving (Show)+instance FromJSON Token where+    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } -$(deriveJSON defaultOptions ''User)+instance ToJSON Token where+    toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } +instance FromJSON User where+    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++instance ToJSON User where+    toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' }+ --------------------------------------------------  main :: IO ()@@ -59,15 +71,15 @@     mgr <- newManager tlsManagerSettings     case xs of         ["offline"] -> offlineCase mgr-        _ -> normalCase mgr+        _           -> normalCase mgr  offlineCase :: Manager -> IO () offlineCase mgr = do-    BS.putStrLn $ authorizationUrl googleKey `appendQueryParam` (googleScopeEmail ++ googleAccessOffline)+    BS.putStrLn $ serializeURIRef' $ appendQueryParams (googleScopeEmail ++ googleAccessOffline) $ authorizationUrl googleKey     putStrLn "visit the url and paste code here: "-    code <- fmap BS.pack getLine-    (Right token) <- fetchAccessToken mgr googleKey code-    f token+    code <- getLine+    (Right token) <- fetchAccessToken mgr googleKey $ ExchangeToken $ T.pack code+    f (accessToken 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@@ -86,19 +98,19 @@  normalCase :: Manager -> IO () normalCase mgr = do-    BS.putStrLn $ authorizationUrl googleKey `appendQueryParam` googleScopeUserInfo+    BS.putStrLn $ serializeURIRef' $ appendQueryParams googleScopeUserInfo (authorizationUrl googleKey)     putStrLn "visit the url and paste code here: "-    code <- fmap BS.pack getLine+    code <- fmap (ExchangeToken . T.pack) getLine     (Right token) <- fetchAccessToken mgr googleKey code     putStr "AccessToken: " >> print token     -- get response in ByteString-    validateToken mgr token >>= print+    validateToken mgr (accessToken token) >>= print     -- get response in JSON-    (validateToken' mgr token :: IO (OAuth2Result Token)) >>= print+    (validateToken' mgr (accessToken token):: IO (OAuth2Result Token)) >>= print     -- get response in ByteString-    userinfo mgr token >>= print+    userinfo mgr (accessToken token) >>= print     -- get response in JSON-    (userinfo' mgr token :: IO (OAuth2Result User)) >>= print+    (userinfo' mgr (accessToken token) :: IO (OAuth2Result User)) >>= print  -------------------------------------------------- -- Google API@@ -122,13 +134,13 @@                  -> IO (OAuth2Result BL.ByteString) validateToken mgr token =    authGetBS' mgr token url-   where url = "https://www.googleapis.com/oauth2/v1/tokeninfo"+   where url = [uri|https://www.googleapis.com/oauth2/v1/tokeninfo|]  validateToken' :: FromJSON a                   => Manager                   -> AccessToken                   -> IO (OAuth2Result a)-validateToken' mgr token = liftM parseResponseJSON $ validateToken mgr token+validateToken' mgr token = parseResponseJSON <$> validateToken mgr token  -- | fetch user email. --   for more information, please check the playround site.@@ -136,10 +148,10 @@ userinfo :: Manager             -> AccessToken             -> IO (OAuth2Result BL.ByteString)-userinfo mgr token = authGetBS mgr token "https://www.googleapis.com/oauth2/v2/userinfo"+userinfo mgr token = authGetBS mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|]  userinfo' :: FromJSON a              => Manager              -> AccessToken              -> IO (OAuth2Result a)-userinfo' mgr token = authGetJSON mgr token "https://www.googleapis.com/oauth2/v2/userinfo"+userinfo' mgr token = authGetJSON mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|]

@@ -1,70 +1,72 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}  module Keys where  import           Network.OAuth.OAuth2+import           URI.ByteString.QQ  weiboKey :: OAuth2 weiboKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"                    , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"-                   , oauthCallback = Just "http://127.0.0.1:9988/oauthCallback"-                   , oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/authorize"-                   , oauthAccessTokenEndpoint = "https://api.weibo.com/oauth2/access_token"+                   , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|]+                   , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|]+                   , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]                    }  -- | http://developer.github.com/v3/oauth/ githubKey :: OAuth2 githubKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"                     , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"-                    , oauthCallback = Just "http://127.0.0.1:9988/githubCallback"-                    , oauthOAuthorizeEndpoint = "https://github.com/login/oauth/authorize"-                    , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"+                    , oauthCallback = Just [uri|http://127.0.0.1:9988/githubCallback|]+                    , oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|]+                    , oauthAccessTokenEndpoint = [uri|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 "http://127.0.0.1:9988/googleCallback"-                   , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth"-                   , oauthAccessTokenEndpoint = "https://www.googleapis.com/oauth2/v3/token"+                   , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|]+                   , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|]+                   , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]                    }  facebookKey :: OAuth2 facebookKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"                      , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"-                     , oauthCallback = Just "http://t.haskellcn.org/cb"-                     , oauthOAuthorizeEndpoint = "https://www.facebook.com/dialog/oauth"-                     , oauthAccessTokenEndpoint = "https://graph.facebook.com/v2.3/oauth/access_token"+                     , oauthCallback = Just [uri|http://t.haskellcn.org/cb|]+                     , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|]+                     , oauthAccessTokenEndpoint = [uri|https://graph.facebook.com/v2.3/oauth/access_token|]                      }  doubanKey :: OAuth2 doubanKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"                    , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxx"-                   , oauthCallback = Just "http://localhost:9999/oauthCallback"-                   , oauthOAuthorizeEndpoint = "https://www.douban.com/service/auth2/auth"-                   , oauthAccessTokenEndpoint = "https://www.douban.com/service/auth2/token"+                   , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|]+                   , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|]+                   , oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]                    }  fitbitKey :: OAuth2 fitbitKey = OAuth2 { oauthClientId = "xxxxxx"                    , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"-                   , oauthCallback = Just "http://localhost:9988/oauth2/callback"-                   , oauthOAuthorizeEndpoint = "https://www.fitbit.com/oauth2/authorize"-                   , oauthAccessTokenEndpoint = "https://api.fitbit.com/oauth2/token"+                   , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+                   , oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|]+                   , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]                    }  stackexchangeKey :: OAuth2 stackexchangeKey = OAuth2 { oauthClientId = "xx"                           , oauthClientSecret = "xxxxxxxxxxxxxxx"-                          , oauthCallback = Just "http://c.haskellcn.org/cb"-                          , oauthOAuthorizeEndpoint = "https://stackexchange.com/oauth"-                          , oauthAccessTokenEndpoint = "https://stackexchange.com/oauth/access_token"+                          , oauthCallback = Just [uri|http://c.haskellcn.org/cb|]+                          , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|]+                          , oauthAccessTokenEndpoint = [uri|https://stackexchange.com/oauth/access_token|]                           } dropboxKey :: OAuth2 dropboxKey = OAuth2 { oauthClientId = "xxx"                     , oauthClientSecret = "xxx"-                    , oauthCallback = Just "http://localhost:9988/oauth2/callback"-                    , oauthOAuthorizeEndpoint = "https://www.dropbox.com/1/oauth2/authorize"-                    , oauthAccessTokenEndpoint = "https://api.dropboxapi.com/oauth2/token"+                    , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+                    , oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|]+                    , oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]                     }

@@ -1,62 +1,85 @@+{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE QuasiQuotes       #-} --- | Github API: http://developer.github.com/v3/oauth/+-- | https://api.stackexchange.com/docs/authentication  module Main where -import           Data.Aeson.TH         (defaultOptions, deriveJSON)+import           Data.Aeson+import           Data.Aeson.Types import qualified Data.ByteString.Char8 as BS import           Data.Text             (Text) import qualified Data.Text             as T import qualified Data.Text.Encoding    as T+import           GHC.Generics import           Network.HTTP.Conduit+import           URI.ByteString+import           URI.ByteString.QQ +import           Keys                  (stackexchangeKey) import           Network.OAuth.OAuth2 -import           Keys+data SiteInfo = SiteInfo { items          :: [SiteItem]+                         , hasMore        :: Bool+                         , quotaMax       :: Integer+                         , quotaRemaining :: Integer+                         } deriving (Show, Eq, Generic) -data SiteInfo = SiteInfo { items           :: [SiteItem]-                         , has_more        :: Bool-                         , quota_max       :: Integer-                         , quota_remaining :: Integer-                         } deriving (Show, Eq)+data SiteItem = SiteItem { newActiveUsers       :: Integer+                           , totalUsers         :: Integer+                           , badgesPerMinute    :: Double+                           , totalBadges        :: Integer+                           , totalVotes         :: Integer+                           , totalComments      :: Integer+                           , answersPerMinute   :: Double+                           , questionsPerMinute :: Double+                           , totalAnswers       :: Integer+                           , totalAccepted      :: Integer+                           , totalUnanswered    :: Integer+                           , totalQuestions     :: Integer+                           , apiRevision        :: Text+                         } deriving (Show, Eq, Generic) -data SiteItem = SiteItem { new_active_users       :: Integer-                           , total_users          :: Integer-                           , badges_per_minute    :: Double-                           , total_badges         :: Integer-                           , total_votes          :: Integer-                           , total_comments       :: Integer-                           , answers_per_minute   :: Double-                           , questions_per_minute :: Double-                           , total_answers        :: Integer-                           , total_accepted       :: Integer-                           , total_unanswered     :: Integer-                           , total_questions      :: Integer-                           , api_revision         :: Text-                         } deriving (Show, Eq)+instance FromJSON SiteInfo where+    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } -$(deriveJSON defaultOptions ''SiteInfo)-$(deriveJSON defaultOptions ''SiteItem)+instance ToJSON SiteInfo where+    toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } +instance FromJSON SiteItem where+    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } +instance ToJSON SiteItem where+    toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' }++ main :: IO () main = do-    print $ authorizationUrl stackexchangeKey+    BS.putStrLn $ serializeURIRef' $ authorizationUrl stackexchangeKey     putStrLn "visit the url and paste code here: "-    code <- fmap BS.pack getLine+    code <- fmap (ExchangeToken . T.pack) getLine     mgr <- newManager tlsManagerSettings-    token <- fetchAccessToken mgr stackexchangeKey code+    let (url, body) = accessTokenUrl stackexchangeKey code+    let extraBody = [ ("state", "test")+                    , ("client_id", T.encodeUtf8 $ oauthClientId stackexchangeKey)+                    , ("client_secret", T.encodeUtf8 $ oauthClientSecret stackexchangeKey)+                    ]++    -- NOTE: stackexchange doesn't really comply with standard, its access token response looks like+    -- `access_token=...&expires=1234`.+    -- the `doFlexiblePostRequest` is able to convert it to OAuth2Token type+    -- but the `expires` is lost given standard naming is `expires_in`+    token <- doFlexiblePostRequest mgr stackexchangeKey url (extraBody ++ body)     print token     case token of-      Right at  -> siteInfo mgr at >>= print-      Left _    -> putStrLn "no access token found yet"+      Right at -> siteInfo mgr (accessToken at) >>= print+      Left _   -> putStrLn "no access token found yet"  -- | Test API: info siteInfo :: Manager -> AccessToken -> IO (OAuth2Result SiteInfo)-siteInfo mgr token = authGetJSON mgr token "https://api.stackexchange.com/2.2/info?site=stackoverflow"+siteInfo mgr token = authGetJSON mgr token [uri|https://api.stackexchange.com/2.2/info?site=stackoverflow|]  sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}  {- @@ -26,20 +27,22 @@ import qualified Data.Text.Encoding         as T import           Network.HTTP.Conduit import           Network.OAuth.OAuth2+import           URI.ByteString+import           URI.ByteString.QQ  import           Keys  main :: IO () main = do-       print $ authorizationUrl weiboKey+       print $ serializeURIRef' $ authorizationUrl weiboKey        putStrLn "visit the url and paste code here: "        code <- getLine        mgr <- newManager tlsManagerSettings-       token <- fetchAccessToken mgr weiboKey (sToBS code)+       token <- fetchAccessToken mgr weiboKey (ExchangeToken $ T.pack code)        print token        case token of          Right r -> do-                    uid <- authGetBS' mgr r "https://api.weibo.com/2/account/get_uid.json"+                    uid <- authGetBS' mgr (accessToken r) [uri|https://api.weibo.com/2/account/get_uid.json|]                     print uid          Left l -> BSL.putStrLn l 

@@ -1,23 +1,27 @@ Name:                hoauth2 -- http://wiki.haskell.org/Package_versioning_policy-Version:             0.5.9+Version:             1.0.0  Synopsis:            Haskell OAuth2 authentication client-Description:-  Haskell OAuth2 authentication client. Tested with the following services:-  .-  * Google web: <https://developers.google.com/accounts/docs/OAuth2WebServer>-  .-  * Github: <http://developer.github.com/v3/oauth/>-  .-  * Facebook: <http://developers.facebook.com/docs/facebook-login/>-  .-  * Fitbit: <http://dev.fitbit.com/docs/oauth2/>-  .-  * Weibo: <http://open.weibo.com/wiki/Oauth2>-  .-  * Douban: <http://developers.douban.com/wiki/?title=oauth2> +Description: Haskell OAuth2 authentication client. Tested with the following services:+             .+             * Google: <https://developers.google.com/accounts/docs/OAuth2WebServer>+             .+             * Github: <http://developer.github.com/v3/oauth/>+             .+             * Facebook: <http://developers.facebook.com/docs/facebook-login/>+             .+             * Fitbit: <http://dev.fitbit.com/docs/oauth2/>+             .+             * StackExchange: <https://api.stackexchange.com/docs/authentication>+             .+             * DropBox: <https://www.dropbox.com/developers/reference/oauth-guide>+             .+             * Weibo: <http://open.weibo.com/wiki/Oauth2>+             .+             * Douban: <http://developers.douban.com/wiki/?title=oauth2>+ Homepage:            https://github.com/freizl/hoauth2 License:             BSD3 License-file:        LICENSE@@ -29,15 +33,14 @@ stability:           Beta tested-with:         GHC <= 7.10.2 -Extra-source-files:-  README.md-  example/Google/test.hs-  example/Weibo/test.hs-  example/Github/test.hs-  example/Facebook/test.hs-  example/Fitbit/test.hs-  example/Douban/test.hs-  example/Keys.hs.sample+Extra-source-files: README.md+                    example/Keys.hs.sample+                    example/Google/test.hs+                    example/Weibo/test.hs+                    example/Github/test.hs+                    example/Facebook/test.hs+                    example/Fitbit/test.hs+                    example/Douban/test.hs  Cabal-version:       >=1.10 @@ -50,22 +53,23 @@   Default: False  Library-  hs-source-dirs: src-  default-language:    Haskell2010-  Exposed-modules:-    Network.OAuth.OAuth2.HttpClient-    Network.OAuth.OAuth2.Internal-    Network.OAuth.OAuth2--  Build-Depends:-    base                 >= 4     && < 5,-    text                 >= 0.11  && < 1.3,-    bytestring           >= 0.9   && < 0.11,-    http-conduit         >= 2.1   && < 2.3,-    http-types           >= 0.9   && < 0.10,-    aeson                >= 0.11  && < 1.2,-    unordered-containers >= 0.2.5+  hs-source-dirs:   src+  default-language: Haskell2010+  Exposed-modules: Network.OAuth.OAuth2.HttpClient+                   Network.OAuth.OAuth2.Internal+                   Network.OAuth.OAuth2 +  Build-Depends: base                 >= 4     && < 5,+                 aeson                >= 1.0   && < 1.1,+                 text                 >= 0.11  && < 1.3,+                 bytestring           >= 0.9   && < 0.11,+                 http-conduit         >= 2.1   && < 2.3,+                 http-types           >= 0.9   && < 0.10,+                 aeson                >= 0.11  && < 1.2,+                 unordered-containers >= 0.2.5,+                 uri-bytestring       >= 0.2.3.1 && < 0.3,+                 microlens            >= 0.4.0 && < 0.5,+                 exceptions           >= 0.8.3 && < 0.9    if impl(ghc >= 6.12.0)       ghc-options: -Wall -fwarn-tabs -funbox-strict-fields@@ -87,6 +91,7 @@                        http-conduit      >= 2.1    && < 2.3,                        text              >= 0.11   && < 1.3,                        bytestring        >= 0.9    && < 0.11,+                       uri-bytestring    >= 0.2.3.1 && < 0.3,                        aeson             >= 0.11   && < 1.2,                        hoauth2 @@ -111,6 +116,7 @@                        http-conduit      >= 2.1    && < 2.3,                        text              >= 0.11   && < 1.3,                        bytestring        >= 0.9    && < 0.11,+                       uri-bytestring    >= 0.2.3.1 && < 0.3,                        aeson             >= 0.11   && < 1.2,                        hoauth2 @@ -135,6 +141,7 @@                        http-conduit      >= 2.1    && < 2.3,                        text              >= 0.11   && < 1.3,                        bytestring        >= 0.9    && < 0.11,+                       uri-bytestring    >= 0.2.3.1 && < 0.3,                        aeson             >= 0.11   && < 1.2,                        hoauth2 @@ -158,6 +165,7 @@                        http-conduit      >= 2.1    && < 2.3,                        text              >= 0.11   && < 1.3,                        bytestring        >= 0.9    && < 0.11,+                       uri-bytestring    >= 0.2.3.1 && < 0.3,                        aeson             >= 0.11   && < 1.2,                        hoauth2 @@ -181,6 +189,7 @@                        http-conduit      >= 2.1    && < 2.3,                        text              >= 0.11   && < 1.3,                        bytestring        >= 0.9    && < 0.11,+                       uri-bytestring    >= 0.2.3.1 && < 0.3,                        aeson             >= 0.11   && < 1.2,                        hoauth2 @@ -202,6 +211,7 @@   build-depends:       base              >= 4.5    && < 5,                        text              >= 0.11   && < 1.3,                        bytestring        >= 0.9    && < 0.11,+                       uri-bytestring    >= 0.2.3.1 && < 0.3,                        http-conduit      >= 2.1    && < 2.3,                        http-types        >= 0.9    && < 0.10,                        wai               >= 3.2    && < 3.3,@@ -231,6 +241,7 @@                        http-conduit      >= 2.1    && < 2.3,                        text              >= 0.11   && < 1.3,                        bytestring        >= 0.9    && < 0.11,+                       uri-bytestring    >= 0.2.3.1 && < 0.3,                        aeson             >= 0.11   && < 1.2,                        hoauth2 @@ -254,6 +265,7 @@                        http-conduit      >= 2.1    && < 2.3,                        text              >= 0.11   && < 1.3,                        bytestring        >= 0.9    && < 0.11,+                       uri-bytestring    >= 0.2.3.1 && < 0.3,                        aeson             >= 0.11   && < 1.2,                        hoauth2 

@@ -26,7 +26,6 @@   setMethod ) where -import           Control.Monad                 (liftM) import           Data.Aeson import qualified Data.ByteString.Char8         as BS import qualified Data.ByteString.Lazy.Char8    as BSL@@ -37,16 +36,17 @@ import qualified Network.HTTP.Types            as HT import           Network.HTTP.Types.URI        (parseQuery) import           Network.OAuth.OAuth2.Internal+import           URI.ByteString  -------------------------------------------------- -- * Token management -------------------------------------------------- --- | Request (via POST method) "Access Token".+-- | Request (via POST method) "OAuth2 Token". fetchAccessToken :: Manager                          -- ^ HTTP connection manager                    -> OAuth2                         -- ^ OAuth Data-                   -> BS.ByteString                  -- ^ Authentication code gained after authorization-                   -> IO (OAuth2Result AccessToken)  -- ^ Access Token+                   -> ExchangeToken                  -- ^ OAuth 2 Tokens+                   -> IO (OAuth2Result OAuth2Token)  -- ^ Access Token fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body                            where (uri, body) = accessTokenUrl oa code @@ -54,10 +54,10 @@ -- | Request the "Refresh Token". fetchRefreshToken :: Manager                         -- ^ HTTP connection manager.                      -> OAuth2                       -- ^ OAuth context-                     -> BS.ByteString                -- ^ refresh token gained after authorization+                     -> RefreshToken                 -- ^ refresh token gained after authorization                      -> IO (OAuth2Result AccessToken)-fetchRefreshToken manager oa rtoken = doFlexiblePostRequest manager oa uri body-                              where (uri, body) = refreshAccessTokenUrl oa rtoken+fetchRefreshToken manager oa token = doFlexiblePostRequest manager oa uri body+                              where (uri, body) = refreshAccessTokenUrl oa token   -- | Conduct post request and return response as JSON.@@ -67,7 +67,7 @@                   -> URI                                 -- ^ The URL                   -> PostBody                            -- ^ request body                   -> IO (OAuth2Result a)                 -- ^ Response as ByteString-doJSONPostRequest manager oa uri body = liftM parseResponseJSON (doSimplePostRequest manager oa uri body)+doJSONPostRequest manager oa uri body = fmap parseResponseJSON (doSimplePostRequest manager oa uri body)  -- | Conduct post request and return response as JSON or Query String. doFlexiblePostRequest :: FromJSON a@@ -76,7 +76,7 @@                          -> URI                                 -- ^ The URL                          -> PostBody                            -- ^ request body                          -> IO (OAuth2Result a)                 -- ^ Response as ByteString-doFlexiblePostRequest manager oa uri body = liftM parseResponseFlexible (doSimplePostRequest manager oa uri body)+doFlexiblePostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body)  -- | Conduct post request. doSimplePostRequest :: Manager                              -- ^ HTTP connection manager.@@ -84,10 +84,10 @@                        -> URI                               -- ^ URL                        -> PostBody                          -- ^ Request body.                        -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString-doSimplePostRequest manager oa url body = liftM handleResponse go+doSimplePostRequest manager oa url body = fmap handleResponse go                                   where go = do-                                             req <- parseUrl $ BS.unpack url-                                             let addBasicAuth = applyBasicAuth (oauthClientId oa) (oauthClientSecret oa)+                                             req <- uriToRequest url+                                             let addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauthClientId oa) (T.encodeUtf8 $ oauthClientSecret oa)                                                  req' = (addBasicAuth . updateRequestHeaders Nothing) req                                              httpLbs (urlEncodedBody body req') manager @@ -101,7 +101,7 @@                  -> AccessToken                  -> URI                          -- ^ Full URL                  -> IO (OAuth2Result a)          -- ^ Response as JSON-authGetJSON manager t uri = liftM parseResponseJSON $ authGetBS manager t uri+authGetJSON manager t uri = parseResponseJSON <$> authGetBS manager t uri  -- | Conduct GET request. authGetBS :: Manager                              -- ^ HTTP connection manager.@@ -109,17 +109,17 @@              -> URI                               -- ^ URL              -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString authGetBS manager token url = do-  req <- parseUrl $ BS.unpack url+  req <- uriToRequest url   authRequest req upReq manager   where upReq = updateRequestHeaders (Just token) . setMethod HT.GET  -- | same to 'authGetBS' but set access token to query parameter rather than header-authGetBS' :: Manager                              -- ^ HTTP connection manager.+authGetBS' :: Manager                             -- ^ HTTP connection manager.              -> AccessToken              -> URI                               -- ^ URL              -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString authGetBS' manager token url = do-  req <- parseUrl $ BS.unpack $ url `appendAccessToken` token+  req <- uriToRequest (url `appendAccessToken` token)   authRequest req upReq manager   where upReq = updateRequestHeaders Nothing . setMethod HT.GET @@ -130,7 +130,7 @@                  -> URI                          -- ^ Full URL                  -> PostBody                  -> IO (OAuth2Result a)          -- ^ Response as JSON-authPostJSON manager t uri pb = liftM parseResponseJSON $ authPostBS manager t uri pb+authPostJSON manager t uri pb = parseResponseJSON <$> authPostBS manager t uri pb  -- | Conduct POST request. authPostBS :: Manager                             -- ^ HTTP connection manager.@@ -139,20 +139,20 @@              -> PostBody              -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString authPostBS manager token url pb = do-  req <- parseUrl $ BS.unpack url+  req <- uriToRequest url   authRequest req upReq manager   where upBody = urlEncodedBody (pb ++ accessTokenToParam token)         upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST         upReq = upHeaders . upBody  -- | Conduct POST request with access token in the request body rather header-authPostBS' :: Manager                             -- ^ HTTP connection manager.+authPostBS' :: Manager                            -- ^ HTTP connection manager.              -> AccessToken              -> URI                               -- ^ URL              -> PostBody              -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString authPostBS' manager token url pb = do-  req <- parseUrl $ BS.unpack url+  req <- uriToRequest url   authRequest req upReq manager   where upBody = urlEncodedBody (pb ++ accessTokenToParam token)         upHeaders = updateRequestHeaders Nothing . setMethod HT.POST@@ -163,9 +163,9 @@ -- authRequest :: Request                          -- ^ Request to perform                -> (Request -> Request)          -- ^ Modify request before sending-               -> Manager                          -- ^ HTTP connection manager.+               -> Manager                       -- ^ HTTP connection manager.                -> IO (OAuth2Result BSL.ByteString)-authRequest req upReq manager = liftM handleResponse (httpLbs (upReq req)  manager)+authRequest req upReq manager = fmap handleResponse (httpLbs (upReq req) manager)  -------------------------------------------------- -- * Utilities@@ -183,9 +183,16 @@               => OAuth2Result BSL.ByteString               -> OAuth2Result a parseResponseJSON (Left b) = Left b-parseResponseJSON (Right b) = case decode b of-                            Nothing -> Left ("hoauth2.HttpClient.parseResponseJSON/Could not decode JSON: " `BSL.append` b)-                            Just x -> Right x+parseResponseJSON (Right b) = case eitherDecode b of+                            Left msg -> Left ("hoauth2.HttpClient.parseResponseJSON/Could not decode JSON: "+                                              `BSL.append`+                                              b+                                               `BSL.append`+                                             ", with error: "+                                               `BSL.append`+                                               BSL.pack msg+                                             )+                            Right x -> Right x  -- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String parseResponseString :: FromJSON a@@ -195,12 +202,12 @@ parseResponseString (Right b) = case parseQuery $ BSL.toStrict b of                               [] -> Left errorMessage                               a -> case fromJSON $ queryToValue a of-                                    Error _ -> Left errorMessage+                                    Error _   -> Left errorMessage                                     Success x -> Right x   where     queryToValue = Object . HM.fromList . map paramToPair     paramToPair (k, mv) = (T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)-    errorMessage = "hoauth2.HttpClient.parseResponseJSON/Could not decode JSON or URL: " `BSL.append` b+    errorMessage = "hoauth2.HttpClient.parseResponseString/Could not decode URL: " `BSL.append` b  -- | Try 'parseResponseJSON' and 'parseResponseString' parseResponseFlexible :: FromJSON a@@ -208,7 +215,7 @@                          -> OAuth2Result a parseResponseFlexible r = case parseResponseJSON r of                            Left _ -> parseResponseString r-                           x -> x+                           x      -> x  -- | Set several header values: --   + userAgennt    : `hoauth2`@@ -218,7 +225,7 @@ updateRequestHeaders t req =   let extras = [ (HT.hUserAgent, "hoauth2")                , (HT.hAccept, "application/json") ]-      bearer = [(HT.hAuthorization, "Bearer " `BS.append` accessToken (fromJust t)) | isJust t]+      bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (fromJust (fmap atoken t))) | isJust t]       headers = bearer ++ extras ++ requestHeaders req   in   req { requestHeaders = headers }

@@ -1,4 +1,7 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TupleSections              #-}  {-# OPTIONS_HADDOCK -ignore-exports #-} @@ -7,14 +10,21 @@  module Network.OAuth.OAuth2.Internal where -import           Control.Applicative  ((<$>), (<*>))-import           Control.Monad        (mzero)+import           Control.Arrow        (second)+import           Control.Monad.Catch import           Data.Aeson+import           Data.Aeson.Types import qualified Data.ByteString      as BS import qualified Data.ByteString.Lazy as BSL import           Data.Maybe+import           Data.Text            (Text) import           Data.Text.Encoding-import           Network.HTTP.Types   (renderSimpleQuery)+import           GHC.Generics+import           Lens.Micro+import           Lens.Micro.Extras+import           Network.HTTP.Conduit as C+import qualified Network.HTTP.Types   as H+import           URI.ByteString  -------------------------------------------------- -- * Data Types@@ -22,35 +32,36 @@  -- | Query Parameter Representation data OAuth2 = OAuth2 {-      oauthClientId            :: BS.ByteString-    , oauthClientSecret        :: BS.ByteString-    , oauthOAuthorizeEndpoint  :: BS.ByteString-    , oauthAccessTokenEndpoint :: BS.ByteString-    , oauthCallback            :: Maybe BS.ByteString+      oauthClientId            :: Text+    , oauthClientSecret        :: Text+    , oauthOAuthorizeEndpoint  :: URI+    , oauthAccessTokenEndpoint :: URI+    , oauthCallback            :: Maybe URI     } deriving (Show, Eq) +newtype AccessToken = AccessToken { atoken :: Text } deriving (Show, FromJSON, ToJSON)+newtype RefreshToken = RefreshToken { rtoken :: Text } deriving (Show, FromJSON, ToJSON)+newtype IdToken = IdToken { idtoken :: Text } deriving (Show, FromJSON, ToJSON)+newtype ExchangeToken = ExchangeToken { extoken :: Text } deriving (Show, FromJSON, ToJSON) + -- | The gained Access Token. Use @Data.Aeson.decode@ to -- decode string to @AccessToken@.  The @refreshToken@ is -- special in some cases, -- e.g. <https://developers.google.com/accounts/docs/OAuth2>-data AccessToken = AccessToken {-      accessToken  :: BS.ByteString-    , refreshToken :: Maybe BS.ByteString+data OAuth2Token = OAuth2Token {+      accessToken  :: AccessToken+    , refreshToken :: Maybe RefreshToken     , expiresIn    :: Maybe Int-    , tokenType    :: Maybe BS.ByteString-    , idToken      :: Maybe BS.ByteString-    } deriving (Show)+    , tokenType    :: Maybe Text+    , idToken      :: Maybe IdToken+    } deriving (Show, Generic) --- | Parse JSON data into 'AccessToken'-instance FromJSON AccessToken where-    parseJSON (Object o) = AccessToken <$> at <*> rt <*> ei <*> tt <*> id_ where-        at = fmap encodeUtf8 $ o .: "access_token"-        rt = fmap (fmap encodeUtf8) $ o .:? "refresh_token"-        ei = o .:? "expires_in"-        tt = fmap (fmap encodeUtf8) $ o .:? "token_type"-        id_ = fmap (fmap encodeUtf8) $ o .:? "id_token"-    parseJSON _ = mzero+-- | Parse JSON data into 'OAuth2Token'+instance FromJSON OAuth2Token where+    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }+instance ToJSON OAuth2Token where+    toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' }  -------------------------------------------------- -- * Types Synonym@@ -59,15 +70,10 @@ -- | 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-+type QueryParams = [(BS.ByteString, BS.ByteString)]  -------------------------------------------------- -- * URLs@@ -76,63 +82,90 @@ -- | 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)]-+authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauthOAuthorizeEndpoint oa)+  where queryParts = catMaybes [ Just ("client_id", encodeUtf8 $ oauthClientId oa)+                               , Just ("response_type", "code")+                               , fmap (("redirect_uri",) . serializeURIRef') (oauthCallback oa) ]  -- | Prepare the URL and the request body query for fetching an access token. accessTokenUrl :: OAuth2-                  -> BS.ByteString       -- ^ access code gained via authorization URL-                  -> (URI, PostBody)     -- ^ access token request URL plus the request body.+                  -> ExchangeToken    -- ^ 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")  -- | Prepare the URL and the request body query for fetching an access token, with -- optional grant type. 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.+                    -> ExchangeToken   -- ^ access code gained via authorization URL+                    -> Maybe Text      -- ^ Grant Type+                    -> (URI, PostBody) -- ^ access token request URL plus the request body. accessTokenUrl' oa code gt = (uri, body)   where uri  = oauthAccessTokenEndpoint oa-        body = transform' [ ("code", Just code)-                          , ("redirect_uri", oauthCallback oa)-                          , ("grant_type", gt)-                          ]+        body = catMaybes [ Just ("code", encodeUtf8 $ extoken code)+                         , (("redirect_uri",) . serializeURIRef') <$> oauthCallback oa+                         , fmap (("grant_type",) . encodeUtf8) 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+                         -> RefreshToken     -- ^ refresh token gained via authorization URL                          -> (URI, PostBody)  -- ^ refresh token request URL plus the request body.-refreshAccessTokenUrl oa rtoken = (uri, body)+refreshAccessTokenUrl oa token = (uri, body)   where uri = oauthAccessTokenEndpoint oa-        body = transform' [ ("grant_type", Just "refresh_token")-                          , ("refresh_token", Just rtoken)-                          ]------------------------------------------------------- * UTILs------------------------------------------------------- | Append query parameters using `"?"` or `"&"`.-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+        body = [ ("grant_type", "refresh_token")+               , ("refresh_token", encodeUtf8 $ rtoken token)+               ]  -- | For `GET` method API.-appendAccessToken :: URI               -- ^ Base URI-                     -> AccessToken    -- ^ Authorized Access Token-                     -> URI            -- ^ Combined Result-appendAccessToken uri t = appendQueryParam uri (accessTokenToParam t)+appendAccessToken :: URIRef a             -- ^ Base URI+                     -> AccessToken       -- ^ Authorized Access Token+                     -> URIRef a          -- ^ Combined Result+appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri  -- | Create 'QueryParams' with given access token value.-accessTokenToParam :: AccessToken -> QueryParams-accessTokenToParam at = [("access_token", accessToken at)]+accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)]+accessTokenToParam t = [("access_token", encodeUtf8 $ atoken t)] +appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a+appendQueryParams params =+  over (queryL . queryPairsL) (params ++ ) --- | Lift value in the 'Maybe' and abandon 'Nothing'.-transform' :: [(a, Maybe b)] -> [(a, b)]-transform' = map (\(a, Just b) -> (a, b)) . filter (isJust . snd)+uriToRequest :: MonadThrow m => URI -> m Request+uriToRequest uri = do+  ssl <- case view (uriSchemeL . schemeBSL) uri of+    "http" -> return False+    "https" -> return True+    s -> throwM $ InvalidUrlException (show uri) ("Invalid scheme: " ++ show s)+  let+    query = fmap (second Just) (view (queryL . queryPairsL) uri)+    hostL = authorityL . _Just . authorityHostL . hostBSL+    portL = authorityL . _Just . authorityPortL . _Just . portNumberL+    defaultPort = (if ssl then 443 else 80) :: Int++    req = setQueryString query $ defaultRequest {+        secure = ssl,+        path = view pathL uri+      }+    req2 = (over hostLens . maybe id const . preview hostL) uri req+    req3 = (over portLens . maybe (const defaultPort) const . preview portL) uri req2+  return req3++requestToUri :: Request -> URI+requestToUri req =+  URI+    (Scheme (if secure req+           then "https"+           else "http"))+    (Just (Authority Nothing (Host $ host req) (Just $ Port $ port req)))+    (path req)+    (Query $ H.parseSimpleQuery $ queryString req)+    Nothing++hostLens :: Lens' Request BS.ByteString+hostLens f req = f (C.host req) <&> \h' -> req { C.host = h' }+{-# INLINE hostLens #-}++portLens :: Lens' Request Int+portLens f req = f (C.port req) <&> \p' -> req { C.port = p' }+{-# INLINE portLens #-}