hoauth2 0.4.8 → 0.5.0
raw patch · 10 files changed
+171/−38 lines, 10 filesdep +containersdep +waidep +warpdep ~aesondep ~basedep ~http-typesnew-component:exe:test-fitbit
Dependencies added: containers, wai, warp
Dependency ranges changed: aeson, base, http-types
Files
- README.md +2/−2
- example/Douban/test.hs +1/−2
- example/Facebook/test.hs +1/−3
- example/Fitbit/test.hs +105/−0
- example/Github/test.hs +1/−3
- example/Google/test.hs +1/−6
- example/Keys.hs.sample +7/−0
- example/Weibo/test.hs +1/−2
- hoauth2.cabal +52/−19
- src/Network/OAuth/OAuth2/Internal.hs +0/−1
README.md view
@@ -1,5 +1,5 @@-[](http://travis-ci.org/freizl/hoauth2)-+[](http://travis-ci.org/freizl/hoauth2)+[](https://hackage.haskell.org/package/hoauth2) # Introduction A lightweight oauth2 haskell binding. See examples in `example/` folder.
example/Douban/test.hs view
@@ -26,7 +26,7 @@ print $ authorizationUrl doubanKey putStrLn "visit the url and paste code here: " code <- getLine- mgr <- newManager conduitManagerSettings+ mgr <- newManager tlsManagerSettings token <- fetchAccessToken mgr doubanKey (sToBS code) print token case token of@@ -34,7 +34,6 @@ uid <- authGetBS mgr r "https://api.douban.com/v2/user/~me" print uid Left l -> BSL.putStrLn l- closeManager mgr sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack
example/Facebook/test.hs view
@@ -16,7 +16,6 @@ import Data.Text (Text) import Network.HTTP.Conduit import Prelude hiding (id)-import qualified Prelude as P (id) -------------------------------------------------- @@ -34,7 +33,7 @@ print $ authorizationUrl facebookKey `appendQueryParam` facebookScope putStrLn "visit the url and paste code here: " code <- fmap BS.pack getLine- mgr <- newManager conduitManagerSettings+ mgr <- newManager tlsManagerSettings let (url, body) = accessTokenUrl facebookKey code resp <- doJSONPostRequest mgr facebookKey url (body ++ [("state", "test")]) case (resp :: OAuth2Result AccessToken) of@@ -43,7 +42,6 @@ --userinfo mgr token >>= print userinfo' mgr token >>= print Left l -> print l- closeManager mgr -------------------------------------------------- -- FaceBook API
+ example/Fitbit/test.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad (mzero)+import Data.Aeson+import Data.Char (chr)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as M+import Network.HTTP.Conduit hiding (queryString,Request)+import Network.Wai+import Network.HTTP.Types (status200,Query)+import Network.Wai.Handler.Warp (run)++import Network.OAuth.OAuth2+import Keys (fitbitKey)++------------------------------------------------------------------------------++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 $ authorizationUrl fitbitKey `appendQueryParam` [("state", state), ("scope", "profile")]+ 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 token+ print user+ return $ encode user++getApiCode :: Request -> B.ByteString+getApiCode request =+ case M.lookup "code" queryMap of+ Just code -> code+ Nothing -> error "request doesn't include code"+ where+ queryMap = convertQueryToMap $ queryString request++getApiToken :: Manager -> B.ByteString -> IO (AccessToken)+getApiToken mgr code = do+ result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)]+ case result of+ Right token -> return token+ Left e -> error $ lazyBSToString e+ where+ (url, body) = accessTokenUrl fitbitKey code++getApiUser :: Manager -> AccessToken -> IO (FitbitUser)+getApiUser mgr token = do+ result <- authGetJSON mgr token "https://api.fitbit.com/1/user/-/profile.json"+ case result of+ Right user -> return user+ Left e -> error $ lazyBSToString e++convertQueryToMap :: Query -> M.Map B.ByteString B.ByteString+convertQueryToMap query =+ M.fromList $ map normalize query+ where+ normalize (k, Just v) = (k, v)+ normalize (k, Nothing) = (k, B.empty)++lazyBSToString :: BL.ByteString -> String+lazyBSToString s = map (chr . fromIntegral) (BL.unpack s)
example/Github/test.hs view
@@ -5,7 +5,6 @@ module Main where -import Control.Applicative import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as BS@@ -25,14 +24,13 @@ print $ authorizationUrl githubKey `appendQueryParam` [("state", state)] putStrLn "visit the url and paste code here: " code <- getLine- mgr <- newManager conduitManagerSettings+ mgr <- newManager tlsManagerSettings let (url, body) = accessTokenUrl githubKey (sToBS code) token <- doJSONPostRequest mgr githubKey url (body ++ [("state", state)]) print (token :: OAuth2Result AccessToken) case token of Right at -> userInfo mgr at >>= print Left _ -> putStrLn "no access token found yet"- closeManager mgr -- | Test API: user
example/Google/test.hs view
@@ -24,7 +24,6 @@ import Data.Text (Text) import Network.HTTP.Conduit import Prelude hiding (id)-import qualified Prelude as P (id) import System.Environment (getArgs) --------------------------------------------------@@ -34,8 +33,6 @@ , user_id :: Maybe Text , scope :: Text , expires_in :: Integer- -- , email :: Maybe Text- -- , verified_email :: Maybe Bool , access_type :: Text } deriving (Show) @@ -49,7 +46,6 @@ , link :: Text , picture :: Text , gender :: Text- , birthday :: Text , locale :: Text } deriving (Show) @@ -60,11 +56,10 @@ main :: IO () main = do xs <- getArgs- mgr <- newManager conduitManagerSettings+ mgr <- newManager tlsManagerSettings case xs of ["offline"] -> offlineCase mgr _ -> normalCase mgr- closeManager mgr offlineCase :: Manager -> IO () offlineCase mgr = do
example/Keys.hs.sample view
@@ -46,3 +46,10 @@ , oauthAccessTokenEndpoint = "https://www.douban.com/service/auth2/token" } +fitbitKey :: OAuth2+fitbitKey = OAuth2 { oauthClientId = "xxxxxx"+ , oauthClientSecret = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just "http://localhost:9988/oauth2/callback"+ , oauthOAuthorizeEndpoint = "https://www.fitbit.com/oauth2/authorize"+ , oauthAccessTokenEndpoint = "https://api.fitbit.com/oauth2/token"+ }
example/Weibo/test.hs view
@@ -34,7 +34,7 @@ print $ authorizationUrl weiboKey putStrLn "visit the url and paste code here: " code <- getLine- mgr <- newManager conduitManagerSettings+ mgr <- newManager tlsManagerSettings token <- fetchAccessToken mgr weiboKey (sToBS code) print token case token of@@ -42,7 +42,6 @@ uid <- authGetBS' mgr r "https://api.weibo.com/2/account/get_uid.json" print uid Left l -> BSL.putStrLn l- closeManager mgr sToBS :: String -> BS.ByteString sToBS = T.encodeUtf8 . T.pack
hoauth2.cabal view
@@ -1,6 +1,6 @@ Name: hoauth2 -- https://wiki.haskell.org/Package_versioning_policy-Version: 0.4.8+Version: 0.5.0 Synopsis: hoauth2 Description:@@ -10,9 +10,15 @@ . * google web oauth: <https://developers.google.com/accounts/docs/OAuth2WebServer> .+ * github oauth: <http://developer.github.com/v3/oauth/>+ .+ * facebook+ .+ * fitbit+ . * weibo oauth2: <http://open.weibo.com/wiki/Oauth2> .- * github oauth: <http://developer.github.com/v3/oauth/>+ * douban <http://developers.douban.com/wiki/?title=oauth2> Homepage: https://github.com/freizl/hoauth2 License: BSD3@@ -23,7 +29,7 @@ Category: Network Build-type: Simple stability: alpha-tested-with: GHC <= 7.6.3+tested-with: GHC <= 7.10.2 -- Extra files to be distributed with the package, such as examples or@@ -58,11 +64,11 @@ Build-Depends: base >= 4 && < 5,- aeson >= 0.7 && < 0.10,+ aeson >= 0.10 && < 0.11, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, http-conduit >= 2.0 && < 2.2,- http-types >= 0.8 && < 0.9+ http-types >= 0.9 && < 0.10 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields@@ -79,8 +85,8 @@ main-is: Weibo/test.hs hs-source-dirs: example default-language: Haskell2010- build-depends: base >=4.5 && <5,- http-types >= 0.8 && < 0.9,+ build-depends: base >= 4.5 && < 5,+ http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11,@@ -102,12 +108,12 @@ main-is: Google/test.hs hs-source-dirs: example default-language: Haskell2010- build-depends: base >=4.5 && <5,- http-types >= 0.8 && < 0.9,+ build-depends: base >= 4.5 && < 5,+ http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11,- aeson >= 0.7 && < 0.10,+ aeson >= 0.10 && < 0.11, hoauth2 if impl(ghc >= 6.12.0)@@ -126,12 +132,12 @@ main-is: Github/test.hs hs-source-dirs: example default-language: Haskell2010- build-depends: base >=4.5 && <5,- http-types >= 0.8 && < 0.9,+ build-depends: base >= 4.5 && < 5,+ http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11,- aeson >= 0.7 && < 0.10,+ aeson >= 0.10 && < 0.11, hoauth2 if impl(ghc >= 6.12.0)@@ -149,12 +155,12 @@ main-is: Douban/test.hs hs-source-dirs: example default-language: Haskell2010- build-depends: base >=4.5 && <5,- http-types >= 0.8 && < 0.9,+ build-depends: base >= 4.5 && < 5,+ http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11,- aeson >= 0.7 && < 0.10,+ aeson >= 0.10 && < 0.11, hoauth2 if impl(ghc >= 6.12.0)@@ -172,16 +178,43 @@ main-is: Facebook/test.hs hs-source-dirs: example default-language: Haskell2010- build-depends: base >=4.5 && <5,- http-types >= 0.8 && < 0.9,+ build-depends: base >= 4.5 && < 5,+ http-types >= 0.9 && < 0.10, http-conduit >= 2.0 && < 2.2, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11,- aeson >= 0.7 && < 0.10,+ aeson >= 0.10 && < 0.11, 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,+ aeson >= 0.10 && < 0.11,+ text >= 0.11 && < 1.3,+ bytestring >= 0.9 && < 0.11,+ http-conduit >= 2.0 && < 2.2,+ http-types >= 0.9 && < 0.10,+ wai >= 3.0 && < 3.2,+ warp >= 3.0 && < 3.2,+ containers >= 0.4 && < 0.6,+ 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
src/Network/OAuth/OAuth2/Internal.hs view
@@ -7,7 +7,6 @@ module Network.OAuth.OAuth2.Internal where -import Control.Applicative ((<$>), (<*>)) import Control.Monad (mzero) import Data.Aeson import qualified Data.ByteString as BS