diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -[![Build Status](https://secure.travis-ci.org/freizl/hoauth2.png?branch=master)](http://travis-ci.org/freizl/hoauth2) - +[![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. diff --git a/example/Douban/test.hs b/example/Douban/test.hs --- a/example/Douban/test.hs +++ b/example/Douban/test.hs @@ -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 diff --git a/example/Facebook/test.hs b/example/Facebook/test.hs --- a/example/Facebook/test.hs +++ b/example/Facebook/test.hs @@ -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 diff --git a/example/Fitbit/test.hs b/example/Fitbit/test.hs new file mode 100644 --- /dev/null +++ b/example/Fitbit/test.hs @@ -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) diff --git a/example/Github/test.hs b/example/Github/test.hs --- a/example/Github/test.hs +++ b/example/Github/test.hs @@ -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 diff --git a/example/Google/test.hs b/example/Google/test.hs --- a/example/Google/test.hs +++ b/example/Google/test.hs @@ -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 diff --git a/example/Keys.hs.sample b/example/Keys.hs.sample --- a/example/Keys.hs.sample +++ b/example/Keys.hs.sample @@ -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" + } diff --git a/example/Weibo/test.hs b/example/Weibo/test.hs --- a/example/Weibo/test.hs +++ b/example/Weibo/test.hs @@ -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 diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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: . + * github oauth: + . + * facebook + . + * fitbit + . * weibo oauth2: . - * github oauth: + * douban 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 diff --git a/src/Network/OAuth/OAuth2/Internal.hs b/src/Network/OAuth/OAuth2/Internal.hs --- a/src/Network/OAuth/OAuth2/Internal.hs +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -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