hoauth2-1.3.0/example/0000755000000000000000000000000013071464360012712 5ustar0000000000000000hoauth2-1.3.0/example/Douban/0000755000000000000000000000000013127445330014120 5ustar0000000000000000hoauth2-1.3.0/example/Dropbox/0000755000000000000000000000000013127445330014325 5ustar0000000000000000hoauth2-1.3.0/example/Facebook/0000755000000000000000000000000013127445330014421 5ustar0000000000000000hoauth2-1.3.0/example/Fitbit/0000755000000000000000000000000013127445330014131 5ustar0000000000000000hoauth2-1.3.0/example/Github/0000755000000000000000000000000013127445330014132 5ustar0000000000000000hoauth2-1.3.0/example/Google/0000755000000000000000000000000013127447430014127 5ustar0000000000000000hoauth2-1.3.0/example/StackExchange/0000755000000000000000000000000013127445330015420 5ustar0000000000000000hoauth2-1.3.0/example/Weibo/0000755000000000000000000000000013127445330013755 5ustar0000000000000000hoauth2-1.3.0/src/0000755000000000000000000000000012772273445012057 5ustar0000000000000000hoauth2-1.3.0/src/Network/0000755000000000000000000000000012642343106013474 5ustar0000000000000000hoauth2-1.3.0/src/Network/OAuth/0000755000000000000000000000000013071334533014515 5ustar0000000000000000hoauth2-1.3.0/src/Network/OAuth/OAuth2/0000755000000000000000000000000013127447567015635 5ustar0000000000000000hoauth2-1.3.0/src/Network/OAuth/OAuth2/HttpClient.hs0000644000000000000000000002467613127447565020264 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | A simple http client to request OAuth2 tokens and several utils. module Network.OAuth.OAuth2.HttpClient ( -- * Token management fetchAccessToken, fetchRefreshToken, doJSONPostRequest, doFlexiblePostRequest, doSimplePostRequest, -- * AUTH requests authGetJSON, authGetBS, authGetBS', authPostJSON, authPostBS, authPostBS', authRequest, -- * Utilities handleResponse, parseResponseJSON, parseResponseFlexible, updateRequestHeaders, setMethod ) where import Data.Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.HashMap.Strict as HM (fromList) import Data.Maybe import qualified Data.Text.Encoding as T import Network.HTTP.Conduit hiding (withManager) import qualified Network.HTTP.Types as HT 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 TR.Errors OAuth2Token) -- ^ Access Token fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code -- | 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 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 err => FromJSON a => Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth options -> URI -- ^ The URL -> PostBody -- ^ request body -> 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 err => FromJSON a => Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth options -> URI -- ^ The URL -> PostBody -- ^ request body -> IO (OAuth2Result err a) -- ^ Response as ByteString doFlexiblePostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body) -- | Conduct post request. 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 let addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauthClientId oa) (T.encodeUtf8 $ oauthClientSecret oa) req' = (addBasicAuth . updateRequestHeaders Nothing) req httpLbs (urlEncodedBody body req') manager -------------------------------------------------- -- * AUTH requests -------------------------------------------------- -- | Conduct an authorized GET request and return response as JSON. authGetJSON :: FromJSON err => FromJSON a => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (OAuth2Result err a) -- ^ Response as JSON authGetJSON manager t uri = parseResponseJSON <$> authGetBS manager t uri -- | Conduct an authorized GET request. authGetBS :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> 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' :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> 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 err => FromJSON a => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err a) -- ^ Response as JSON authPostJSON manager t uri pb = parseResponseJSON <$> authPostBS manager t uri pb -- | Conduct POST request. authPostBS :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString authPostBS manager token url pb = do 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' :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString authPostBS' manager token url pb = do req <- uriToRequest url authRequest req upReq manager where upBody = urlEncodedBody (pb ++ accessTokenToParam token) upHeaders = updateRequestHeaders Nothing . setMethod HT.POST upReq = upHeaders . upBody -- |Send an HTTP request including the Authorization header with the specified -- access token. -- authRequest :: FromJSON err => Request -- ^ Request to perform -> (Request -> Request) -- ^ Modify request before sending -> Manager -- ^ HTTP connection manager. -> IO (OAuth2Result err BSL.ByteString) authRequest req upReq manager = fmap handleResponse (httpLbs (upReq req) manager) -------------------------------------------------- -- * Utilities -------------------------------------------------- -- | Parses a @Response@ to to @OAuth2Result@ handleResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString handleResponse rsp = if HT.statusIsSuccessful (responseStatus rsp) then Right $ responseBody rsp else Left $ parseOAuth2Error (responseBody rsp) -- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@ parseResponseJSON :: FromJSON err => FromJSON a => OAuth2Result err BSL.ByteString -> OAuth2Result err a parseResponseJSON (Left b) = Left b 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 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 a -> case fromJSON $ queryToValue a of 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 = parseOAuth2Error b -- | Try 'parseResponseJSON' and 'parseResponseString' parseResponseFlexible :: FromJSON err => FromJSON a => OAuth2Result err BSL.ByteString -> OAuth2Result err a parseResponseFlexible r = case parseResponseJSON r of Left _ -> parseResponseString r x -> x -- | Set several header values: -- + userAgennt : `hoauth2` -- + accept : `application/json` -- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = let extras = [ (HT.hUserAgent, "hoauth2") , (HT.hAccept, "application/json") ] bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (fromJust (fmap atoken t))) | isJust t] headers = bearer ++ extras ++ requestHeaders req in req { requestHeaders = headers } -- | Set the HTTP method to use. setMethod :: HT.StdMethod -> Request -> Request setMethod m req = req { method = HT.renderStdMethod m } hoauth2-1.3.0/src/Network/OAuth/OAuth2/Internal.hs0000644000000000000000000001766313127445330017744 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK -ignore-exports #-} -- | A simple OAuth2 Haskell binding. (This is supposed to be -- independent of the http client used.) 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.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 -------------------------------------------------- -- * Data Types -------------------------------------------------- -- | Query Parameter Representation data OAuth2 = OAuth2 { 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. data OAuth2Token = OAuth2Token { accessToken :: AccessToken , refreshToken :: Maybe RefreshToken , expiresIn :: Maybe Int , tokenType :: Maybe Text , idToken :: Maybe IdToken } deriving (Show, Generic) -- | Parse JSON data into 'OAuth2Token' instance FromJSON OAuth2Token where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } 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 err a = Either (OAuth2Error err) a -- | type synonym of post body content type PostBody = [(BS.ByteString, BS.ByteString)] type QueryParams = [(BS.ByteString, BS.ByteString)] -------------------------------------------------- -- * URLs -------------------------------------------------- -- | Prepare the authorization URL. Redirect to this URL -- asking for user interactive authentication. authorizationUrl :: OAuth2 -> URI 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 -> 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 -> 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 = 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 -> RefreshToken -- ^ refresh token gained via authorization URL -> (URI, PostBody) -- ^ refresh token request URL plus the request body. refreshAccessTokenUrl oa token = (uri, body) where uri = oauthAccessTokenEndpoint oa body = [ ("grant_type", "refresh_token") , ("refresh_token", encodeUtf8 $ rtoken token) ] -- | For `GET` method API. 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 -> [(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 ++ ) 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 #-} hoauth2-1.3.0/src/Network/OAuth/OAuth2.hs0000644000000000000000000000124113022275636016155 0ustar0000000000000000------------------------------------------------------------ -- | -- Module : Network.OAuth.OAuth2 -- Description : OAuth2 client -- Copyright : (c) 2012 Haisheng Wu -- License : BSD-style (see the file LICENSE) -- Maintainer : Haisheng Wu -- Stability : alpha -- Portability : portable -- -- A lightweight oauth2 haskell binding. ------------------------------------------------------------ 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 hoauth2-1.3.0/src/Network/OAuth/OAuth2/TokenRequest.hs0000644000000000000000000000132413127445330020604 0ustar0000000000000000{-# 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) hoauth2-1.3.0/src/Network/OAuth/OAuth2/AuthorizationRequest.hs0000644000000000000000000000154513127445330022371 0ustar0000000000000000{-# 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) hoauth2-1.3.0/example/Dropbox/test.hs0000644000000000000000000000305213127445330015640 0ustar0000000000000000{-# 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 putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings token <- fetchAccessToken mgr dropboxKey (ExchangeToken (T.pack code)) print token case token of Right at -> getSpaceUsage mgr (accessToken at) >>= print Left _ -> putStrLn "no access token found yet" 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 where upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST upBody req = req {requestBody = "null" } upReq = upHeaders . upBody hoauth2-1.3.0/example/StackExchange/test.hs0000644000000000000000000000742413127445330016742 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | https://api.stackexchange.com/docs/authentication module Main where 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 data SiteInfo = SiteInfo { items :: [SiteItem] , hasMore :: Bool , quotaMax :: Integer , quotaRemaining :: Integer } deriving (Show, Eq, Generic) 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) instance FromJSON SiteInfo where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } 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 '_' } 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 putStrLn "visit the url and paste code here: " code <- fmap (ExchangeToken . T.pack) getLine mgr <- newManager tlsManagerSettings 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 (accessToken at) >>= print Left (_ :: OAuth2Error Errors) -> putStrLn "no access token found yet" -- | Test API: info 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 sToBS = T.encodeUtf8 . T.pack hoauth2-1.3.0/example/Fitbit/test.hs0000644000000000000000000000773713127445330015462 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Monad (mzero) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Char (chr) 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 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 { userId :: Text , userName :: Text , userAge :: Int } deriving (Show, Eq) instance FromJSON FitbitUser where parseJSON (Object o) = FitbitUser <$> ((o .: "user") >>= (.: "encodedId")) <*> ((o .: "user") >>= (.: "fullName")) <*> ((o .: "user") >>= (.: "age")) parseJSON _ = mzero instance ToJSON FitbitUser where toJSON (FitbitUser fid name age) = object [ "id" .= fid , "name" .= name , "age" .= age ] ------------------------------------------------------------------------------ main :: IO () main = do print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey putStrLn "visit the url to continue" run 9988 application state :: B.ByteString state = "testFitbitApi" application :: Application application request respond = do response <- handleRequest requestPath request respond $ responseLBS status200 [("Content-Type", "text/plain")] response where requestPath = T.intercalate "/" $ pathInfo request handleRequest :: Text -> Request -> IO BL.ByteString handleRequest "favicon.ico" _ = return "" handleRequest _ request = do mgr <- newManager tlsManagerSettings token <- getApiToken mgr $ getApiCode request print token user <- getApiUser mgr (accessToken token) print user return $ encode user getApiCode :: Request -> ExchangeToken getApiCode request = case M.lookup "code" queryMap of Just code -> ExchangeToken $ T.decodeUtf8 code Nothing -> Prelude.error "request doesn't include code" where queryMap = convertQueryToMap $ queryString request 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 :: OAuth2Error Errors) -> Prelude.error $ show e where (url, body) = accessTokenUrl fitbitKey code getApiUser :: Manager -> AccessToken -> IO FitbitUser getApiUser mgr token = do result <- authGetJSON mgr token [uri|https://api.fitbit.com/1/user/-/profile.json|] case result of Right user -> return user Left (e :: OAuth2Error Errors) -> Prelude.error $ show 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, Nothing) = (k, B.empty) lazyBSToString :: BL.ByteString -> String lazyBSToString s = map (chr . fromIntegral) (BL.unpack s) hoauth2-1.3.0/example/Facebook/test.hs0000644000000000000000000000540513127445330015740 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {- Facebook example -} module Main where import Keys (facebookKey) import Network.OAuth.OAuth2 import Data.Aeson.TH (defaultOptions, deriveJSON) 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 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 , name :: Text , email :: Text } deriving (Show) $(deriveJSON defaultOptions ''User) -------------------------------------------------- main :: IO () main = do print $ serializeURIRef' $ appendQueryParams facebookScope $ authorizationUrl facebookKey putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings 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 Errors OAuth2Token) of Right token -> do print token userinfo mgr (accessToken token) >>= print userinfo' mgr (accessToken token) >>= print Left l -> print l -------------------------------------------------- -- 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 :: 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 Errors User) userinfo' mgr token = authGetJSON mgr token [uri|https://graph.facebook.com/me?fields=id,name,email|] hoauth2-1.3.0/example/Douban/test.hs0000644000000000000000000000362713127445330015443 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {- douban oauth2: http://developers.douban.com/wiki/?title=oauth2 /v2/movie/nowplaying -} module Main where import qualified Data.ByteString.Char8 as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy.Encoding as TL import Network.HTTP.Conduit import URI.ByteString import URI.ByteString.QQ import Network.OAuth.OAuth2 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 putStrLn "visit the url and paste code here: " code <- fmap (ExchangeToken . T.pack) getLine mgr <- newManager tlsManagerSettings let (url, body) = accessTokenUrl doubanKey code let extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId doubanKey) , ("client_secret", T.encodeUtf8 $ oauthClientSecret doubanKey) ] 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|] putStrLn $ either (show :: OAuth2Error Errors -> String) (show . TL.decodeUtf8) uid Left l -> print l sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-1.3.0/example/Github/test.hs0000644000000000000000000000464413127445330015455 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} -- | Github API: http://developer.github.com/v3/oauth/ module Main where import Control.Monad (mzero) import qualified Data.ByteString as BS import Data.Text (Text) 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 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 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 (OAuth2Error Errors) GithubUser) userInfo mgr token = authGetJSON mgr token [uri|https://api.github.com/user|] data GithubUser = GithubUser { gid :: Integer , gname :: Text } deriving (Show, Eq) instance FromJSON GithubUser where parseJSON (Object o) = GithubUser <$> o .: "id" <*> o .: "name" parseJSON _ = mzero sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-1.3.0/example/Google/test.hs0000644000000000000000000001421313127447430015443 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {- This is basically very manual test. Check following link for details. Google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer Google OAuth 2.0 playround: https://developers.google.com/oauthplayground/ -} module Main where 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 Errors = SomeRandomError deriving (Show, Eq, Generic) instance FromJSON Errors where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } -------------------------------------------------- data Token = Token { issuedTo :: Text , audience :: Text , userId :: Maybe Text , scope :: Text , expiresIn :: Integer , accessType :: Text } deriving (Show, Generic) data User = User { id :: Text , name :: Text , givenName :: Text , familyName :: Text , link :: Text , picture :: Text , gender :: Text , locale :: Text } deriving (Show, Generic) instance FromJSON Token where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } 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 () main = do xs <- getArgs mgr <- newManager tlsManagerSettings case xs of ["offline"] -> offlineCase mgr _ -> normalCase mgr offlineCase :: Manager -> IO () offlineCase mgr = do BS.putStrLn $ serializeURIRef' $ appendQueryParams (googleScopeEmail ++ googleAccessOffline) $ authorizationUrl googleKey putStrLn "offline mode: visit the url and paste code here: " 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 -- case refreshToken token of Nothing -> putStrLn "Failed to fetch refresh token" Just tk -> do (Right token') <- fetchRefreshToken mgr googleKey tk 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 (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 "normal mode: visit the url and paste code here: " code <- fmap (ExchangeToken . T.pack) getLine 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 (OAuth2Error Errors) Token)) >>= print -- get response in ByteString userinfo mgr (accessToken token) >>= print -- get response in JSON (userinfo' mgr (accessToken token) :: IO (OAuth2Result (OAuth2Error Errors) User)) >>= print -------------------------------------------------- -- Google API -- | This is special for google Gain read-only access to the user's email address. googleScopeEmail :: QueryParams googleScopeEmail = [("scope", "https://www.googleapis.com/auth/userinfo.email")] -- | Gain read-only access to basic profile information, including a googleScopeUserInfo :: QueryParams googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")] -- | Access offline googleAccessOffline :: QueryParams googleAccessOffline = [("access_type", "offline") ,("approval_prompt", "force")] -- | Token Validation validateToken :: Manager -> AccessToken -> IO (OAuth2Result (OAuth2Error Errors) BL.ByteString) validateToken mgr token = authGetBS' mgr token url where url = [uri|https://www.googleapis.com/oauth2/v1/tokeninfo|] validateToken' :: FromJSON a => Manager -> AccessToken -> IO (OAuth2Result (OAuth2Error Errors) a) validateToken' mgr token = parseResponseJSON <$> validateToken mgr token -- | fetch user email. -- for more information, please check the playround site. -- userinfo :: Manager -> AccessToken -> 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 (OAuth2Error Errors) a) userinfo' mgr token = authGetJSON mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|] hoauth2-1.3.0/example/Weibo/test.hs0000644000000000000000000000400313127445330015265 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {- weibo oauth2: http://open.weibo.com/wiki/Oauth2 This is very trivial testing of the httpclient api. 1. this case will print out a URL 2. run the URL in browser and will navigate to weibo auth page 3. conform the authentication and browser will navigate back to the callback url, which obviously will failed cause there is no local server. 4. copy the `code` in the callback url and parse into console 5. this test case will gain access token using the `code` and print it out. check for integration testing at: https://github.com/HaskellCNOrg/snaplet-oauth/tree/master/test -} module Main where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import Network.OAuth.OAuth2 import URI.ByteString import URI.ByteString.QQ 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 putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings token <- fetchAccessToken mgr weiboKey (ExchangeToken $ T.pack code) print token case token of Right r -> do uid <- authGetBS' mgr (accessToken r) [uri|https://api.weibo.com/2/account/get_uid.json|] print (uid :: OAuth2Result (OAuth2Error Errors) BSL.ByteString) Left l -> print l sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-1.3.0/LICENSE0000644000000000000000000000276413071233003012261 0ustar0000000000000000Copyright (c)2012-2017, Haisheng Wu All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Haisheng Wu nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hoauth2-1.3.0/Setup.hs0000644000000000000000000000005612642343106012711 0ustar0000000000000000import Distribution.Simple main = defaultMain hoauth2-1.3.0/hoauth2.cabal0000644000000000000000000002334113127626660013625 0ustar0000000000000000Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy Version: 1.3.0 Synopsis: Haskell OAuth2 authentication client Description: Haskell OAuth2 authentication client. Tested with the following services: . * Google: . * Github: . * Facebook: . * Fitbit: . * StackExchange: . * DropBox: . * Weibo: . * Douban: Homepage: https://github.com/freizl/hoauth2 License: BSD3 License-file: LICENSE Author: Haisheng Wu Maintainer: Haisheng Wu Copyright: Haisheng Wu Category: Network Build-type: Simple stability: Beta tested-with: GHC <= 7.10.2 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 Source-Repository head Type: git Location: git://github.com/freizl/hoauth2.git Flag test Description: Build the executables Default: False Library hs-source-dirs: src default-language: Haskell2010 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, bytestring >= 0.9 && < 0.11, http-conduit >= 2.1 && < 2.3, http-types >= 0.9 && < 0.10, 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 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-weibo if flag(test) Buildable: True else Buildable: False main-is: Weibo/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, 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.3, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-google if flag(test) Buildable: True else Buildable: False main-is: Google/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, 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.3, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-github if flag(test) Buildable: True else Buildable: False main-is: Github/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, 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.3, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-douban if flag(test) Buildable: True else Buildable: False main-is: Douban/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, 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.3, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-facebook if flag(test) Buildable: True else Buildable: False main-is: Facebook/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, 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.3, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-fitbit if flag(test) Buildable: True else Buildable: False main-is: Fitbit/test.hs hs-source-dirs: example default-language: Haskell2010 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, warp >= 3.2 && < 3.3, containers >= 0.4 && < 0.6, aeson >= 0.11 && < 1.3, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-stackexchange if flag(test) Buildable: True else Buildable: False main-is: StackExchange/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, 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.3, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields Executable test-dropbox if flag(test) Buildable: True else Buildable: False main-is: Dropbox/test.hs hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5, http-types >= 0.9 && < 0.10, 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.3, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields hoauth2-1.3.0/README.md0000644000000000000000000000057212642343106012537 0ustar0000000000000000[![Build Status](https://secure.travis-ci.org/freizl/hoauth2.svg?branch=master)](http://travis-ci.org/freizl/hoauth2) [![Hackage](https://img.shields.io/hackage/v/hoauth2.svg)](https://hackage.haskell.org/package/hoauth2) # Introduction A lightweight oauth2 haskell binding. See examples in `example/` folder. # Contribute Feel free send pull request or submit issue ticket. hoauth2-1.3.0/example/Keys.hs.sample0000644000000000000000000000737013071464360015450 0ustar0000000000000000{-# 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 [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 [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 [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 [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 [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 [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 [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 [uri|http://localhost:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|] , oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|] } hoauth2-1.3.0/example/Google/test.hs0000644000000000000000000001421313127447430015443 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {- This is basically very manual test. Check following link for details. Google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer Google OAuth 2.0 playround: https://developers.google.com/oauthplayground/ -} module Main where 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 Errors = SomeRandomError deriving (Show, Eq, Generic) instance FromJSON Errors where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } -------------------------------------------------- data Token = Token { issuedTo :: Text , audience :: Text , userId :: Maybe Text , scope :: Text , expiresIn :: Integer , accessType :: Text } deriving (Show, Generic) data User = User { id :: Text , name :: Text , givenName :: Text , familyName :: Text , link :: Text , picture :: Text , gender :: Text , locale :: Text } deriving (Show, Generic) instance FromJSON Token where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } 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 () main = do xs <- getArgs mgr <- newManager tlsManagerSettings case xs of ["offline"] -> offlineCase mgr _ -> normalCase mgr offlineCase :: Manager -> IO () offlineCase mgr = do BS.putStrLn $ serializeURIRef' $ appendQueryParams (googleScopeEmail ++ googleAccessOffline) $ authorizationUrl googleKey putStrLn "offline mode: visit the url and paste code here: " 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 -- case refreshToken token of Nothing -> putStrLn "Failed to fetch refresh token" Just tk -> do (Right token') <- fetchRefreshToken mgr googleKey tk 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 (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 "normal mode: visit the url and paste code here: " code <- fmap (ExchangeToken . T.pack) getLine 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 (OAuth2Error Errors) Token)) >>= print -- get response in ByteString userinfo mgr (accessToken token) >>= print -- get response in JSON (userinfo' mgr (accessToken token) :: IO (OAuth2Result (OAuth2Error Errors) User)) >>= print -------------------------------------------------- -- Google API -- | This is special for google Gain read-only access to the user's email address. googleScopeEmail :: QueryParams googleScopeEmail = [("scope", "https://www.googleapis.com/auth/userinfo.email")] -- | Gain read-only access to basic profile information, including a googleScopeUserInfo :: QueryParams googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")] -- | Access offline googleAccessOffline :: QueryParams googleAccessOffline = [("access_type", "offline") ,("approval_prompt", "force")] -- | Token Validation validateToken :: Manager -> AccessToken -> IO (OAuth2Result (OAuth2Error Errors) BL.ByteString) validateToken mgr token = authGetBS' mgr token url where url = [uri|https://www.googleapis.com/oauth2/v1/tokeninfo|] validateToken' :: FromJSON a => Manager -> AccessToken -> IO (OAuth2Result (OAuth2Error Errors) a) validateToken' mgr token = parseResponseJSON <$> validateToken mgr token -- | fetch user email. -- for more information, please check the playround site. -- userinfo :: Manager -> AccessToken -> 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 (OAuth2Error Errors) a) userinfo' mgr token = authGetJSON mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|] hoauth2-1.3.0/example/Weibo/test.hs0000644000000000000000000000400313127445330015265 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {- weibo oauth2: http://open.weibo.com/wiki/Oauth2 This is very trivial testing of the httpclient api. 1. this case will print out a URL 2. run the URL in browser and will navigate to weibo auth page 3. conform the authentication and browser will navigate back to the callback url, which obviously will failed cause there is no local server. 4. copy the `code` in the callback url and parse into console 5. this test case will gain access token using the `code` and print it out. check for integration testing at: https://github.com/HaskellCNOrg/snaplet-oauth/tree/master/test -} module Main where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import Network.OAuth.OAuth2 import URI.ByteString import URI.ByteString.QQ 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 putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings token <- fetchAccessToken mgr weiboKey (ExchangeToken $ T.pack code) print token case token of Right r -> do uid <- authGetBS' mgr (accessToken r) [uri|https://api.weibo.com/2/account/get_uid.json|] print (uid :: OAuth2Result (OAuth2Error Errors) BSL.ByteString) Left l -> print l sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-1.3.0/example/Github/test.hs0000644000000000000000000000464413127445330015455 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} -- | Github API: http://developer.github.com/v3/oauth/ module Main where import Control.Monad (mzero) import qualified Data.ByteString as BS import Data.Text (Text) 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 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 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 (OAuth2Error Errors) GithubUser) userInfo mgr token = authGetJSON mgr token [uri|https://api.github.com/user|] data GithubUser = GithubUser { gid :: Integer , gname :: Text } deriving (Show, Eq) instance FromJSON GithubUser where parseJSON (Object o) = GithubUser <$> o .: "id" <*> o .: "name" parseJSON _ = mzero sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack hoauth2-1.3.0/example/Facebook/test.hs0000644000000000000000000000540513127445330015740 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {- Facebook example -} module Main where import Keys (facebookKey) import Network.OAuth.OAuth2 import Data.Aeson.TH (defaultOptions, deriveJSON) 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 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 , name :: Text , email :: Text } deriving (Show) $(deriveJSON defaultOptions ''User) -------------------------------------------------- main :: IO () main = do print $ serializeURIRef' $ appendQueryParams facebookScope $ authorizationUrl facebookKey putStrLn "visit the url and paste code here: " code <- getLine mgr <- newManager tlsManagerSettings 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 Errors OAuth2Token) of Right token -> do print token userinfo mgr (accessToken token) >>= print userinfo' mgr (accessToken token) >>= print Left l -> print l -------------------------------------------------- -- 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 :: 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 Errors User) userinfo' mgr token = authGetJSON mgr token [uri|https://graph.facebook.com/me?fields=id,name,email|] hoauth2-1.3.0/example/Fitbit/test.hs0000644000000000000000000000773713127445330015462 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Monad (mzero) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Char (chr) 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 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 { userId :: Text , userName :: Text , userAge :: Int } deriving (Show, Eq) instance FromJSON FitbitUser where parseJSON (Object o) = FitbitUser <$> ((o .: "user") >>= (.: "encodedId")) <*> ((o .: "user") >>= (.: "fullName")) <*> ((o .: "user") >>= (.: "age")) parseJSON _ = mzero instance ToJSON FitbitUser where toJSON (FitbitUser fid name age) = object [ "id" .= fid , "name" .= name , "age" .= age ] ------------------------------------------------------------------------------ main :: IO () main = do print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey putStrLn "visit the url to continue" run 9988 application state :: B.ByteString state = "testFitbitApi" application :: Application application request respond = do response <- handleRequest requestPath request respond $ responseLBS status200 [("Content-Type", "text/plain")] response where requestPath = T.intercalate "/" $ pathInfo request handleRequest :: Text -> Request -> IO BL.ByteString handleRequest "favicon.ico" _ = return "" handleRequest _ request = do mgr <- newManager tlsManagerSettings token <- getApiToken mgr $ getApiCode request print token user <- getApiUser mgr (accessToken token) print user return $ encode user getApiCode :: Request -> ExchangeToken getApiCode request = case M.lookup "code" queryMap of Just code -> ExchangeToken $ T.decodeUtf8 code Nothing -> Prelude.error "request doesn't include code" where queryMap = convertQueryToMap $ queryString request 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 :: OAuth2Error Errors) -> Prelude.error $ show e where (url, body) = accessTokenUrl fitbitKey code getApiUser :: Manager -> AccessToken -> IO FitbitUser getApiUser mgr token = do result <- authGetJSON mgr token [uri|https://api.fitbit.com/1/user/-/profile.json|] case result of Right user -> return user Left (e :: OAuth2Error Errors) -> Prelude.error $ show 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, Nothing) = (k, B.empty) lazyBSToString :: BL.ByteString -> String lazyBSToString s = map (chr . fromIntegral) (BL.unpack s) hoauth2-1.3.0/example/Douban/test.hs0000644000000000000000000000362713127445330015443 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {- douban oauth2: http://developers.douban.com/wiki/?title=oauth2 /v2/movie/nowplaying -} module Main where import qualified Data.ByteString.Char8 as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy.Encoding as TL import Network.HTTP.Conduit import URI.ByteString import URI.ByteString.QQ import Network.OAuth.OAuth2 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 putStrLn "visit the url and paste code here: " code <- fmap (ExchangeToken . T.pack) getLine mgr <- newManager tlsManagerSettings let (url, body) = accessTokenUrl doubanKey code let extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId doubanKey) , ("client_secret", T.encodeUtf8 $ oauthClientSecret doubanKey) ] 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|] putStrLn $ either (show :: OAuth2Error Errors -> String) (show . TL.decodeUtf8) uid Left l -> print l sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack