hoauth2 1.2.0 → 1.3.0

raw patch · 13 files changed

+273/−101 lines, 13 filesdep +uri-bytestring-aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: uri-bytestring-aeson

API changes (from Hackage documentation)

Files

• example/Douban/test.hs +17/−5
• example/Dropbox/test.hs +11/−1
• example/Facebook/test.hs +16/−4
• example/Fitbit/test.hs +17/−4
• example/Github/test.hs +25/−6
• example/Google/test.hs +23/−11
• example/StackExchange/test.hs +11/−2
• example/Weibo/test.hs +16/−3
• hoauth2.cabal +4/−1
• src/Network/OAuth/OAuth2/AuthorizationRequest.hs +24/−0
• src/Network/OAuth/OAuth2/HttpClient.hs +56/−61
• src/Network/OAuth/OAuth2/Internal.hs +31/−3
• src/Network/OAuth/OAuth2/TokenRequest.hs +22/−0

@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE ScopedTypeVariables #-}  {- @@ -13,11 +15,9 @@ module Main where  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@@ -26,6 +26,17 @@  import           Keys                       (doubanKey) +import           GHC.Generics+import           Data.Aeson+import           Data.Aeson.Types++data Errors =+  SomeRandomError+  deriving (Show, Eq, Generic)++instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+ main :: IO () main = do   BS.putStrLn $ serializeURIRef' $ authorizationUrl doubanKey@@ -37,13 +48,14 @@                   , ("client_secret", T.encodeUtf8 $ oauthClientSecret doubanKey)                   ] -  token <- doJSONPostRequest mgr doubanKey url (extraBody ++ body)+  token :: OAuth2Result Errors OAuth2Token <- 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 (accessToken r) [uri|https://api.douban.com/v2/user/~me|]-      TL.putStrLn $ either TL.decodeUtf8 TL.decodeUtf8 uid-    Left l -> BSL.putStrLn l+      putStrLn $ either (show :: OAuth2Error Errors -> String) (show . TL.decodeUtf8) uid+    Left l -> print l  sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack

@@ -1,20 +1,30 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric     #-}  module Main where  import qualified Data.ByteString.Char8      as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.Text                  as T+import           Data.Aeson+import           Data.Aeson.Types import           Network.HTTP.Conduit import qualified Network.HTTP.Types         as HT import           URI.ByteString+import           GHC.Generics  import           Network.OAuth.OAuth2  import           Keys +data Errors =+  SomeRandomError+  deriving (Show, Eq, Generic) +instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+ main :: IO () main = do     BS.putStrLn $ serializeURIRef' $ authorizationUrl dropboxKey@@ -27,7 +37,7 @@       Right at -> getSpaceUsage mgr (accessToken at) >>= print       Left _   -> putStrLn "no access token found yet" -getSpaceUsage :: Manager -> AccessToken -> IO (OAuth2Result BSL.ByteString)+getSpaceUsage :: Manager -> AccessToken -> IO (OAuth2Result Errors BSL.ByteString) getSpaceUsage mgr token = do   req <- parseRequest $ BS.unpack "https://api.dropboxapi.com/2/users/get_space_usage"   authRequest req upReq mgr

@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-} {-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE DeriveGeneric     #-}  {- Facebook example -} @@ -10,7 +11,6 @@ import           Keys                       (facebookKey) import           Network.OAuth.OAuth2 -import           Data.Aeson                 (FromJSON) import           Data.Aeson.TH              (defaultOptions, deriveJSON) import qualified Data.ByteString.Lazy.Char8 as BL import           Data.Text                  (Text)@@ -21,6 +21,18 @@ import           URI.ByteString import           URI.ByteString.QQ +import           GHC.Generics+import           Data.Aeson+import           Data.Aeson.Types++data Errors =+  SomeRandomError+  deriving (Show, Eq, Generic)++instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }++ --------------------------------------------------  data User = User { id    :: Text@@ -44,7 +56,7 @@                     , ("client_secret", T.encodeUtf8 $ oauthClientSecret facebookKey)                     ]     resp <- doJSONPostRequest mgr facebookKey url (body ++ extraBody)-    case (resp :: OAuth2Result OAuth2Token) of+    case (resp :: OAuth2Result Errors OAuth2Token) of       Right token -> do                      print token                      userinfo mgr (accessToken token) >>= print@@ -59,8 +71,8 @@ facebookScope = [("scope", "user_about_me,email")]  -- | Fetch user id and email.-userinfo :: Manager -> AccessToken -> IO (OAuth2Result BL.ByteString)+userinfo :: Manager -> AccessToken -> IO (OAuth2Result Errors BL.ByteString) 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' :: FromJSON User => Manager -> AccessToken -> IO (OAuth2Result Errors User) userinfo' mgr token = authGetJSON mgr token [uri|https://graph.facebook.com/me?fields=id,name,email|]

@@ -1,11 +1,12 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Main where  import           Control.Monad            (mzero)-import           Data.Aeson import qualified Data.ByteString          as B import qualified Data.ByteString.Lazy     as BL import           Data.Char                (chr)@@ -23,6 +24,18 @@ import           Keys                     (fitbitKey) import           Network.OAuth.OAuth2 +import           GHC.Generics+import           Data.Aeson+import           Data.Aeson.Types++data Errors =+  SomeRandomError+  deriving (Show, Eq, Generic)++instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }++ ------------------------------------------------------------------------------  data FitbitUser = FitbitUser@@ -78,7 +91,7 @@ getApiCode request =     case M.lookup "code" queryMap of         Just code -> ExchangeToken $ T.decodeUtf8 code-        Nothing   -> error "request doesn't include code"+        Nothing   -> Prelude.error "request doesn't include code"   where     queryMap = convertQueryToMap $ queryString request @@ -87,7 +100,7 @@     result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)]     case result of         Right token -> return token-        Left e      -> error $ lazyBSToString e+        Left (e :: OAuth2Error Errors) -> Prelude.error $ show e   where     (url, body) = accessTokenUrl fitbitKey code @@ -96,7 +109,7 @@     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 :: OAuth2Error Errors) -> Prelude.error $ show e  convertQueryToMap :: Query -> M.Map B.ByteString B.ByteString convertQueryToMap query =

@@ -1,13 +1,13 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE DeriveGeneric     #-}  -- | Github API: http://developer.github.com/v3/oauth/  module Main where  import           Control.Monad        (mzero)-import           Data.Aeson import qualified Data.ByteString      as BS import           Data.Text            (Text) import qualified Data.Text            as T@@ -17,28 +17,47 @@ import           URI.ByteString.QQ  import           Network.OAuth.OAuth2+import qualified Network.OAuth.OAuth2.AuthorizationRequest as AR  import           Keys +import           GHC.Generics+import           Data.Aeson+import           Data.Aeson.Types +data Errors =+  SomeRandomError+  deriving (Show, Eq, Generic)++instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+++ main :: IO () main = do     let state = "testGithubApi"+    mgr <- newManager tlsManagerSettings+    putStrLn "Trying invalid token..."+    failToken <- getToken state "invalidCode" mgr+    print (failToken :: OAuth2Result AR.Errors OAuth2Token)     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 $ ExchangeToken $ T.pack code-    token <- doJSONPostRequest mgr githubKey url (body ++ [("state", state)])-    print (token :: OAuth2Result OAuth2Token)+    token <- getToken state code mgr+    print (token :: OAuth2Result AR.Errors OAuth2Token)     case token of       Right at -> userInfo mgr (accessToken at) >>= print       Left _   -> putStrLn "no access token found yet" +getToken :: FromJSON a => BS.ByteString -> String -> Manager -> IO (OAuth2Result AR.Errors a)+getToken state code mgr = do+    let (url, body) = accessTokenUrl githubKey $ ExchangeToken $ T.pack code+    doJSONPostRequest mgr githubKey url (body ++ [("state", state)])  -- | Test API: user ---userInfo :: Manager -> AccessToken -> IO (OAuth2Result GithubUser)+userInfo :: Manager -> AccessToken -> IO (OAuth2Result (OAuth2Error Errors) GithubUser) userInfo mgr token = authGetJSON mgr token [uri|https://api.github.com/user|]  data GithubUser = GithubUser { gid   :: Integer

@@ -30,6 +30,13 @@ import           Keys                          (googleKey) import           Network.OAuth.OAuth2 +data Errors =+  SomeRandomError+  deriving (Show, Eq, Generic)++instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+ --------------------------------------------------  data Token = Token { issuedTo   :: Text@@ -76,7 +83,7 @@ offlineCase :: Manager -> IO () offlineCase mgr = do     BS.putStrLn $ serializeURIRef' $ appendQueryParams (googleScopeEmail ++ googleAccessOffline) $ authorizationUrl googleKey-    putStrLn "visit the url and paste code here: "+    putStrLn "offline mode: visit the url and paste code here: "     code <- getLine     (Right token) <- fetchAccessToken mgr googleKey $ ExchangeToken $ T.pack code     f (accessToken token)@@ -88,29 +95,34 @@         Nothing -> putStrLn "Failed to fetch refresh token"         Just tk -> do             (Right token') <- fetchRefreshToken mgr googleKey tk-            f token'+            f (accessToken token')             --validateToken accessToken >>= print             --(validateToken' accessToken :: IO (OAuth2Result Token)) >>= print     where f token = do             print token             validateToken mgr token >>= print-            (validateToken' mgr token :: IO (OAuth2Result Token)) >>= print+            (validateToken' mgr token :: IO (OAuth2Result (OAuth2Error Errors) Token)) >>= print  normalCase :: Manager -> IO () normalCase mgr = do+    -- try an invalid token+    putStr "Trying invalid token..."+    validateToken mgr (AccessToken "invalid") >>= print     BS.putStrLn $ serializeURIRef' $ appendQueryParams googleScopeUserInfo (authorizationUrl googleKey)-    putStrLn "visit the url and paste code here: "+    putStrLn "normal mode: visit the url and paste code here: "     code <- fmap (ExchangeToken . T.pack) getLine-    (Right token) <- fetchAccessToken mgr googleKey code+    maybeToken <- fetchAccessToken mgr googleKey code+    print maybeToken+    (Right token) <- return maybeToken     putStr "AccessToken: " >> print token     -- get response in ByteString     validateToken mgr (accessToken token) >>= print     -- get response in JSON-    (validateToken' mgr (accessToken token):: IO (OAuth2Result Token)) >>= print+    (validateToken' mgr (accessToken token):: IO (OAuth2Result (OAuth2Error Errors) Token)) >>= print     -- get response in ByteString     userinfo mgr (accessToken token) >>= print     -- get response in JSON-    (userinfo' mgr (accessToken token) :: IO (OAuth2Result User)) >>= print+    (userinfo' mgr (accessToken token) :: IO (OAuth2Result (OAuth2Error Errors) User)) >>= print  -------------------------------------------------- -- Google API@@ -131,7 +143,7 @@ -- | Token Validation validateToken :: Manager                  -> AccessToken-                 -> IO (OAuth2Result BL.ByteString)+                 -> IO (OAuth2Result (OAuth2Error Errors) BL.ByteString) validateToken mgr token =    authGetBS' mgr token url    where url = [uri|https://www.googleapis.com/oauth2/v1/tokeninfo|]@@ -139,7 +151,7 @@ validateToken' :: FromJSON a                   => Manager                   -> AccessToken-                  -> IO (OAuth2Result a)+                  -> IO (OAuth2Result (OAuth2Error Errors) a) validateToken' mgr token = parseResponseJSON <$> validateToken mgr token  -- | fetch user email.@@ -147,11 +159,11 @@ -- userinfo :: Manager             -> AccessToken-            -> IO (OAuth2Result BL.ByteString)+            -> IO (OAuth2Result (OAuth2Error Errors) BL.ByteString) userinfo mgr token = authGetBS mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|]  userinfo' :: FromJSON a              => Manager              -> AccessToken-             -> IO (OAuth2Result a)+             -> IO (OAuth2Result (OAuth2Error Errors) a) userinfo' mgr token = authGetJSON mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|]

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | https://api.stackexchange.com/docs/authentication @@ -54,7 +55,15 @@ instance ToJSON SiteItem where     toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } +data Errors =+  SomeRandomError+  deriving (Show, Eq, Generic) +instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+++ main :: IO () main = do     BS.putStrLn $ serializeURIRef' $ authorizationUrl stackexchangeKey@@ -75,10 +84,10 @@     print token     case token of       Right at -> siteInfo mgr (accessToken at) >>= print-      Left _   -> putStrLn "no access token found yet"+      Left (_ :: OAuth2Error Errors) -> putStrLn "no access token found yet"  -- | Test API: info-siteInfo :: Manager -> AccessToken -> IO (OAuth2Result SiteInfo)+siteInfo :: Manager -> AccessToken -> IO (OAuth2Result (OAuth2Error Errors) SiteInfo) siteInfo mgr token = authGetJSON mgr token [uri|https://api.stackexchange.com/2.2/info?site=stackoverflow|]  sToBS :: String -> BS.ByteString

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE DeriveGeneric     #-}  {- @@ -22,7 +23,7 @@ module Main where  import qualified Data.ByteString            as BS-import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.ByteString.Lazy       as BSL import qualified Data.Text                  as T import qualified Data.Text.Encoding         as T import           Network.HTTP.Conduit@@ -32,6 +33,18 @@  import           Keys +import           GHC.Generics+import           Data.Aeson+import           Data.Aeson.Types++data Errors =+  SomeRandomError+  deriving (Show, Eq, Generic)++instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }++ main :: IO () main = do        print $ serializeURIRef' $ authorizationUrl weiboKey@@ -43,8 +56,8 @@        case token of          Right r -> do                     uid <- authGetBS' mgr (accessToken r) [uri|https://api.weibo.com/2/account/get_uid.json|]-                    print uid-         Left l -> BSL.putStrLn l+                    print (uid :: OAuth2Result (OAuth2Error Errors) BSL.ByteString)+         Left l -> print l  sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack

@@ -1,6 +1,6 @@ Name:                hoauth2 -- http://wiki.haskell.org/Package_versioning_policy-Version:             1.2.0+Version:             1.3.0  Synopsis:            Haskell OAuth2 authentication client @@ -58,6 +58,8 @@   Exposed-modules: Network.OAuth.OAuth2.HttpClient                    Network.OAuth.OAuth2.Internal                    Network.OAuth.OAuth2+                   Network.OAuth.OAuth2.TokenRequest+                   Network.OAuth.OAuth2.AuthorizationRequest    Build-Depends: base                 >= 4     && < 5,                  text                 >= 0.11  && < 1.3,@@ -67,6 +69,7 @@                  aeson                >= 0.11  && < 1.3,                  unordered-containers >= 0.2.5,                  uri-bytestring       >= 0.2.3.1 && < 0.3,+                 uri-bytestring-aeson >= 0.1   && < 0.2,                  microlens            >= 0.4.0 && < 0.5,                  exceptions           >= 0.8.3 && < 0.9 

@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveGeneric              #-}++module Network.OAuth.OAuth2.AuthorizationRequest where++import           Data.Aeson+import           Data.Aeson.Types+import           GHC.Generics++instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+instance ToJSON Errors where+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }++-- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1+-- Implicit Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.2.2.1+data Errors =+    InvalidRequest+  | UnauthorizedClient+  | AccessDenied+  | UnsupportedResponseType+  | InvalidScope+  | ServerError+  | TemporarilyUnavailable+  deriving (Show, Eq, Generic)

@@ -37,53 +37,55 @@ import           Network.HTTP.Types.URI        (parseQuery) import           Network.OAuth.OAuth2.Internal import           URI.ByteString+import qualified Network.OAuth.OAuth2.TokenRequest as TR  -------------------------------------------------- -- * Token management --------------------------------------------------  -- | Request (via POST method) "OAuth2 Token".-fetchAccessToken :: Manager                          -- ^ HTTP connection manager-                   -> OAuth2                         -- ^ OAuth Data-                   -> ExchangeToken                  -- ^ OAuth 2 Tokens-                   -> IO (OAuth2Result OAuth2Token)  -- ^ Access Token+fetchAccessToken :: Manager                                   -- ^ HTTP connection manager+                   -> OAuth2                                  -- ^ OAuth Data+                   -> ExchangeToken                           -- ^ OAuth 2 Tokens+                   -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body                            where (uri, body) = accessTokenUrl oa code  --- | Request the "Refresh Token".+-- | Request a new AccessToken with the Refresh Token.+-- TODO: seems more approporate to rename to refreshAccessToken fetchRefreshToken :: Manager                         -- ^ HTTP connection manager.                      -> OAuth2                       -- ^ OAuth context                      -> RefreshToken                 -- ^ refresh token gained after authorization-                     -> IO (OAuth2Result AccessToken)+                     -> IO (OAuth2Result TR.Errors OAuth2Token) fetchRefreshToken manager oa token = doFlexiblePostRequest manager oa uri body                               where (uri, body) = refreshAccessTokenUrl oa token   -- | Conduct post request and return response as JSON.-doJSONPostRequest :: FromJSON a+doJSONPostRequest :: FromJSON err => FromJSON a                   => Manager                             -- ^ HTTP connection manager.                   -> OAuth2                              -- ^ OAuth options                   -> URI                                 -- ^ The URL                   -> PostBody                            -- ^ request body-                  -> IO (OAuth2Result a)                 -- ^ Response as ByteString+                  -> IO (OAuth2Result err a)             -- ^ Response as JSON 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+doFlexiblePostRequest :: FromJSON err => FromJSON a                          => Manager                             -- ^ HTTP connection manager.                          -> OAuth2                              -- ^ OAuth options                          -> URI                                 -- ^ The URL                          -> PostBody                            -- ^ request body-                         -> IO (OAuth2Result a)                 -- ^ Response as ByteString+                         -> IO (OAuth2Result err a)             -- ^ Response as ByteString doFlexiblePostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body)  -- | Conduct post request.-doSimplePostRequest :: Manager                              -- ^ HTTP connection manager.-                       -> OAuth2                            -- ^ OAuth options-                       -> URI                               -- ^ URL-                       -> PostBody                          -- ^ Request body.-                       -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString+doSimplePostRequest :: FromJSON err => Manager                 -- ^ HTTP connection manager.+                       -> OAuth2                               -- ^ OAuth options+                       -> URI                                  -- ^ URL+                       -> PostBody                             -- ^ Request body.+                       -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString doSimplePostRequest manager oa url body = fmap handleResponse go                                   where go = do                                              req <- uriToRequest url@@ -95,49 +97,49 @@ -- * AUTH requests -------------------------------------------------- --- | Conduct GET request and return response as JSON.-authGetJSON :: FromJSON a-                 => Manager                      -- ^ HTTP connection manager.+-- | Conduct an authorized GET request and return response as JSON.+authGetJSON :: FromJSON err => FromJSON a+                 => Manager                 -- ^ HTTP connection manager.                  -> AccessToken-                 -> URI                          -- ^ Full URL-                 -> IO (OAuth2Result a)          -- ^ Response as JSON+                 -> URI+                 -> IO (OAuth2Result err a) -- ^ Response as JSON authGetJSON manager t uri = parseResponseJSON <$> authGetBS manager t uri --- | Conduct GET request.-authGetBS :: Manager                              -- ^ HTTP connection manager.+-- | Conduct an authorized GET request.+authGetBS :: FromJSON err => Manager                 -- ^ HTTP connection manager.              -> AccessToken-             -> URI                               -- ^ URL-             -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString+             -> URI+             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString authGetBS manager token url = do   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' :: FromJSON err => Manager                -- ^ HTTP connection manager.              -> AccessToken-             -> URI                               -- ^ URL-             -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString+             -> URI+             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString authGetBS' manager token url = do   req <- uriToRequest (url `appendAccessToken` token)   authRequest req upReq manager   where upReq = updateRequestHeaders Nothing . setMethod HT.GET  -- | Conduct POST request and return response as JSON.-authPostJSON :: FromJSON a-                 => Manager                      -- ^ HTTP connection manager.+authPostJSON :: FromJSON err => FromJSON a+                 => Manager                 -- ^ HTTP connection manager.                  -> AccessToken-                 -> URI                          -- ^ Full URL+                 -> URI                  -> PostBody-                 -> IO (OAuth2Result a)          -- ^ Response as JSON+                 -> IO (OAuth2Result err a) -- ^ Response as JSON authPostJSON manager t uri pb = parseResponseJSON <$> authPostBS manager t uri pb  -- | Conduct POST request.-authPostBS :: Manager                             -- ^ HTTP connection manager.+authPostBS :: FromJSON err => Manager                -- ^ HTTP connection manager.              -> AccessToken-             -> URI                               -- ^ URL+             -> URI              -> PostBody-             -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString+             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString authPostBS manager token url pb = do   req <- uriToRequest url   authRequest req upReq manager@@ -146,11 +148,11 @@         upReq = upHeaders . upBody  -- | Conduct POST request with access token in the request body rather header-authPostBS' :: Manager                            -- ^ HTTP connection manager.+authPostBS' :: FromJSON err => Manager               -- ^ HTTP connection manager.              -> AccessToken-             -> URI                               -- ^ URL+             -> URI              -> PostBody-             -> IO (OAuth2Result BSL.ByteString)  -- ^ Response as ByteString+             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString authPostBS' manager token url pb = do   req <- uriToRequest url   authRequest req upReq manager@@ -161,10 +163,10 @@ -- |Send an HTTP request including the Authorization header with the specified --  access token. ---authRequest :: Request                          -- ^ Request to perform+authRequest :: FromJSON err => Request          -- ^ Request to perform                -> (Request -> Request)          -- ^ Modify request before sending                -> Manager                       -- ^ HTTP connection manager.-               -> IO (OAuth2Result BSL.ByteString)+               -> IO (OAuth2Result err BSL.ByteString) authRequest req upReq manager = fmap handleResponse (httpLbs (upReq req) manager)  --------------------------------------------------@@ -172,32 +174,25 @@ --------------------------------------------------  -- | Parses a @Response@ to to @OAuth2Result@-handleResponse :: Response BSL.ByteString -> OAuth2Result BSL.ByteString+handleResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString handleResponse rsp =     if HT.statusIsSuccessful (responseStatus rsp)         then Right $ responseBody rsp-        else Left $ BSL.append "hoauth2.HttpClient.handleResponse/Gaining token failed: " (responseBody rsp)+        else Left $ parseOAuth2Error (responseBody rsp)  -- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@-parseResponseJSON :: FromJSON a-              => OAuth2Result BSL.ByteString-              -> OAuth2Result a+parseResponseJSON :: FromJSON err => FromJSON a+              => OAuth2Result err BSL.ByteString+              -> OAuth2Result err a parseResponseJSON (Left b) = Left b-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+parseResponseJSON (Right b) = case decode b of+                            Nothing -> Left (parseOAuth2Error b)+                            Just x -> Right x  -- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String-parseResponseString :: FromJSON a-              => OAuth2Result BSL.ByteString-              -> OAuth2Result a+parseResponseString :: FromJSON err => FromJSON a+              => OAuth2Result err BSL.ByteString+              -> OAuth2Result err a parseResponseString (Left b) = Left b parseResponseString (Right b) = case parseQuery $ BSL.toStrict b of                               [] -> Left errorMessage@@ -207,12 +202,12 @@   where     queryToValue = Object . HM.fromList . map paramToPair     paramToPair (k, mv) = (T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)-    errorMessage = "hoauth2.HttpClient.parseResponseString/Could not decode URL: " `BSL.append` b+    errorMessage = parseOAuth2Error b  -- | Try 'parseResponseJSON' and 'parseResponseString'-parseResponseFlexible :: FromJSON a-                         => OAuth2Result BSL.ByteString-                         -> OAuth2Result a+parseResponseFlexible :: FromJSON err => FromJSON a+                         => OAuth2Result err BSL.ByteString+                         -> OAuth2Result err a parseResponseFlexible r = case parseResponseJSON r of                            Left _ -> parseResponseString r                            x      -> x

@@ -10,21 +10,25 @@  module Network.OAuth.OAuth2.Internal where +import           Prelude              hiding (error) import           Control.Arrow        (second)+import           Control.Applicative 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.Monoid+import           Data.Text            (Text, pack) import           Data.Text.Encoding import           GHC.Generics+import           URI.ByteString+import           URI.ByteString.Aeson () 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@@ -63,12 +67,36 @@ instance ToJSON OAuth2Token where     toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } +data OAuth2Error a =+  OAuth2Error+    { error :: Either Text a+    , errorDescription :: Maybe Text+    , errorUri :: Maybe (URIRef Absolute) }+  deriving (Show, Eq, Generic)++instance FromJSON err => FromJSON (OAuth2Error err) where+  parseJSON (Object a) =+    do+      err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str)+      desc <- a .:? "error_description"+      uri <- a .:? "error_uri"+      return $ OAuth2Error err desc uri+  parseJSON _ = fail "Expected an object"++instance ToJSON err => ToJSON (OAuth2Error err) where+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }++parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err+parseOAuth2Error string =+  either (\err -> OAuth2Error (Left "Decode error") (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict string)) Nothing) id (eitherDecode string)++ -------------------------------------------------- -- * Types Synonym --------------------------------------------------  -- | Is either 'Left' containing an error or 'Right' containg a result-type OAuth2Result a = Either BSL.ByteString a+type OAuth2Result err a = Either (OAuth2Error err) a  -- | type synonym of post body content type PostBody = [(BS.ByteString, BS.ByteString)]

@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveGeneric              #-}++module Network.OAuth.OAuth2.TokenRequest where++import           Data.Aeson+import           Data.Aeson.Types+import           GHC.Generics++instance FromJSON Errors where+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+instance ToJSON Errors where+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }++-- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2+data Errors =+    InvalidRequest+  | InvalidClient+  | InvalidGrant+  | UnauthorizedClient+  | UnsupportedGrantType+  | InvalidScope+  deriving (Show, Eq, Generic)