hoauth2 1.6.3 → 1.7.0
raw patch · 34 files changed
+1127/−1093 lines, 34 filesdep +binarydep +hashabledep +mtldep ~basedep ~hoauth2dep ~unordered-containersPVP ok
version bump matches the API change (PVP)
Dependencies added: binary, hashable, mtl, mustache, parsec, scotty, wai-extra, wai-middleware-static
Dependency ranges changed: base, hoauth2, unordered-containers
API changes (from Hackage documentation)
- Network.OAuth.OAuth2.HttpClient: authGetBS' :: FromJSON err => Manager -> AccessToken -> URI -> IO (OAuth2Result err ByteString)
- Network.OAuth.OAuth2.HttpClient: authPostBS' :: FromJSON err => Manager -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err ByteString)
+ Network.OAuth.OAuth2.HttpClient: authGetBS2 :: FromJSON err => Manager -> AccessToken -> URI -> IO (OAuth2Result err ByteString)
+ Network.OAuth.OAuth2.HttpClient: authPostBS2 :: FromJSON err => Manager -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err ByteString)
+ Network.OAuth.OAuth2.HttpClient: authPostBS3 :: FromJSON err => Manager -> AccessToken -> URI -> IO (OAuth2Result err ByteString)
+ Network.OAuth.OAuth2.HttpClient: fetchAccessToken2 :: Manager -> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token)
+ Network.OAuth.OAuth2.HttpClient: refreshAccessToken :: Manager -> OAuth2 -> RefreshToken -> IO (OAuth2Result Errors OAuth2Token)
Files
- example/App.hs +142/−0
- example/Douban/test.hs +0/−61
- example/Dropbox/test.hs +0/−46
- example/Facebook/test.hs +0/−77
- example/Fitbit/test.hs +0/−122
- example/Github/test.hs +0/−74
- example/Google/test.hs +0/−168
- example/IDP.hs +43/−0
- example/IDP/Douban.hs +51/−0
- example/IDP/Dropbox.hs +56/−0
- example/IDP/Facebook.hs +52/−0
- example/IDP/Fitbit.hs +60/−0
- example/IDP/Github.hs +49/−0
- example/IDP/Google.hs +52/−0
- example/IDP/Linkedin.hs +46/−0
- example/IDP/Okta.hs +52/−0
- example/IDP/StackExchange.hs +76/−0
- example/IDP/Weibo.hs +61/−0
- example/Keys.hs +21/−8
- example/Keys.hs.sample +6/−0
- example/Okta/test.hs +0/−47
- example/README.md +13/−0
- example/Session.hs +38/−0
- example/StackExchange/test.hs +0/−94
- example/Types.hs +95/−0
- example/Utils.hs +34/−0
- example/Views.hs +39/−0
- example/Weibo/test.hs +0/−63
- example/assets/main.css +11/−0
- example/demo-server.hs +0/−81
- example/main.hs +6/−0
- example/templates/index.mustache +30/−0
- hoauth2.cabal +47/−242
- src/Network/OAuth/OAuth2/HttpClient.hs +47/−10
+ example/App.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module App (app, waiApp) where++import Control.Monad+import Control.Monad.Error.Class+import Control.Monad.IO.Class (liftIO)+import Data.Bifunctor+import Data.Maybe+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import Network.HTTP.Conduit+import Network.HTTP.Types+import Network.OAuth.OAuth2+import qualified Network.Wai as WAI+import Network.Wai.Handler.Warp (run)+import Network.Wai.Middleware.Static+import Prelude+import Web.Scotty+import Web.Scotty.Internal.Types++import IDP+import Session+import Types+import Utils+import Views++------------------------------+-- App+------------------------------++myServerPort :: Int+myServerPort = 9988++app :: IO ()+app = putStrLn ("Starting Server. http://localhost:" ++ show myServerPort)+ >> waiApp+ >>= run myServerPort++-- TODO: how to add either Monad or a middleware to do session?+waiApp :: IO WAI.Application+waiApp = do+ cache <- initCacheStore+ initIdps cache+ scottyApp $ do+ middleware $ staticPolicy (addBase "example/assets")+ defaultHandler globalErrorHandler+ get "/" $ indexH cache+ get "/oauth2/callback" $ callbackH cache+ get "/logout" $ logoutH cache++debug :: Bool+debug = True++--------------------------------------------------+-- * Handlers+--------------------------------------------------++redirectToHomeM :: ActionM ()+redirectToHomeM = redirect "/"++errorM :: Text -> ActionM ()+errorM = throwError . ActionError++globalErrorHandler :: Text -> ActionM ()+globalErrorHandler t = status status401 >> html t++logoutH :: CacheStore -> ActionM ()+logoutH c = do+ pas <- params+ let idpP = paramValue "idp" pas+ when (null idpP) redirectToHomeM+ let eitherIdpApp = parseIDP (head idpP)+ case eitherIdpApp of+ Right (IDPApp idp) -> liftIO (removeKey c (idpLabel idp)) >> redirectToHomeM+ Left e -> errorM ("logout: unknown IDP " `TL.append` e)++indexH :: CacheStore -> ActionM ()+indexH c = liftIO (allValues c) >>= overviewTpl++callbackH :: CacheStore -> ActionM ()+callbackH c = do+ pas <- params+ let codeP = paramValue "code" pas+ let stateP = paramValue "state" pas+ when (null codeP) (errorM "callbackH: no code from callback request")+ when (null stateP) (errorM "callbackH: no state from callback request")+ let eitherIdpApp = parseIDP (TL.takeWhile (/= '.') (head stateP))+ -- TODO: looks like `state` shall be passed when fetching access token+ -- turns out no IDP enforce this yet+ case eitherIdpApp of+ Right (IDPApp idp) -> fetchTokenAndUser c (head codeP) idp+ Left e -> errorM ("callbackH: cannot find IDP name from text " `TL.append` e)++fetchTokenAndUser :: (HasTokenReq a, HasUserReq a, HasLabel a)+ => CacheStore+ -> TL.Text -- ^ code+ -> a+ -> ActionM ()+fetchTokenAndUser c code idp = do+ maybeIdpData <- lookIdp c idp+ when (isNothing maybeIdpData) (errorM "fetchTokenAndUser: cannot find idp data from cache")++ let idpData = fromJust maybeIdpData+ result <- liftIO $ tryFetchUser idp code++ case result of+ Right luser -> (updateIdp c idpData luser) >> redirectToHomeM+ Left err -> errorM ("fetchTokenAndUser: " `TL.append` err)++ where lookIdp c1 idp1 = liftIO $ lookupKey c1 (idpLabel idp1)+ updateIdp c1 oldIdpData luser = liftIO $ insertIDPData c1 (oldIdpData {loginUser = Just luser })++-- TODO: may use Exception monad to capture error in this IO monad+--+tryFetchUser :: (HasTokenReq a, HasUserReq a, HasLabel a)+ => a+ -> TL.Text -- ^ code+ -> IO (Either Text LoginUser)+tryFetchUser idp code = do+ mgr <- newManager tlsManagerSettings+ token <- tokenReq idp mgr (ExchangeToken $ TL.toStrict code)+ when debug (print token)+ case token of+ Right at -> fetchUser idp mgr (accessToken at)+ Left e -> return (Left $ TL.pack $ "tryFetchUser: cannot fetch asses token. error detail: " ++ show e)++-- * Fetch UserInfo+--+fetchUser :: (HasUserReq a) => a -> Manager -> AccessToken -> IO (Either Text LoginUser)+fetchUser idp mgr token = do+ re <- userReq idp mgr token+ return (first displayOAuth2Error re)++displayOAuth2Error :: OAuth2Error Errors -> Text+displayOAuth2Error = TL.pack . show+
− example/Douban/test.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# 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 Data.Aeson-import Data.Aeson.Types-import GHC.Generics--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
− example/Dropbox/test.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Data.Aeson-import Data.Aeson.Types-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.Text as T-import GHC.Generics-import Network.HTTP.Conduit-import qualified Network.HTTP.Types as HT-import URI.ByteString--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
− example/Facebook/test.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--{- 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 URI.ByteString-import URI.ByteString.QQ--import Data.Aeson-import Data.Aeson.Types-import GHC.Generics--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|]
− example/Fitbit/test.hs
@@ -1,122 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# 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 Data.Aeson-import Data.Aeson.Types-import GHC.Generics--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)
− example/Github/test.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}---- | 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 Data.Aeson-import Data.Aeson.Types-import GHC.Generics--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
− example/Google/test.hs
@@ -1,168 +0,0 @@-{-# 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 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|]
+ example/IDP.hs view
@@ -0,0 +1,43 @@++module IDP where++import Data.Text.Lazy (Text)++import qualified Data.HashMap.Strict as Map+import qualified IDP.Douban as IDouban+import qualified IDP.Dropbox as IDropbox+import qualified IDP.Facebook as IFacebook+import qualified IDP.Fitbit as IFitbit+import qualified IDP.Github as IGithub+import qualified IDP.Google as IGoogle+import qualified IDP.Okta as IOkta+import qualified IDP.StackExchange as IStackExchange+import qualified IDP.Weibo as IWeibo+import Session+import Types++-- TODO: make this generic to discover any IDPs from idp directory.+--+idps :: [IDPApp]+idps = [ IDPApp IDouban.Douban+ , IDPApp IDropbox.Dropbox+ , IDPApp IFacebook.Facebook+ , IDPApp IFitbit.Fitbit+ , IDPApp IGithub.Github+ , IDPApp IGoogle.Google+ , IDPApp IOkta.Okta+ , IDPApp IStackExchange.StackExchange+ , IDPApp IWeibo.Weibo+ ]++initIdps :: CacheStore -> IO ()+initIdps c = mapM_ (insertIDPData c) (fmap mkIDPData idps)++idpsMap :: Map.HashMap Text IDPApp+idpsMap = Map.fromList $ fmap (\x@(IDPApp idp) -> (idpLabel idp, x)) idps++parseIDP :: Text -> Either Text IDPApp+parseIDP s = maybe (Left s) Right (Map.lookup s idpsMap)++mkIDPData :: IDPApp -> IDPData+mkIDPData (IDPApp idp) = IDPData (authUri idp) Nothing (idpLabel idp)
+ example/IDP/Douban.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Douban where+import Data.Aeson+import Data.Aeson.Types+import Data.Bifunctor+import Data.Hashable+import Data.Text.Lazy (Text)+import GHC.Generics+import Keys+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils++data Douban = Douban deriving (Show, Generic)++instance Hashable Douban++instance IDP Douban++instance HasLabel Douban++instance HasTokenReq Douban where+ tokenReq _ mgr = fetchAccessToken2 mgr doubanKey++instance HasUserReq Douban where+ userReq _ mgr at = do+ re <- authGetJSON mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Douban where+ authUri _ = createCodeUri doubanKey [ ("state", "Douban.test-state-123")+ ]++data DoubanUser = DoubanUser { name :: Text+ , uid :: Text+ } deriving (Show, Generic)++instance FromJSON DoubanUser where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://api.douban.com/v2/user/~me|]++toLoginUser :: DoubanUser -> LoginUser+toLoginUser ouser = LoginUser { loginUserName = name ouser }+
+ example/IDP/Dropbox.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Dropbox where+import Data.Aeson+import Data.Aeson.Types+import Data.Bifunctor+import Data.Hashable+import Data.Text.Lazy (Text)+import GHC.Generics+import Keys+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils++data Dropbox = Dropbox deriving (Show, Generic)++instance Hashable Dropbox++instance IDP Dropbox++instance HasLabel Dropbox++instance HasTokenReq Dropbox where+ tokenReq _ mgr = fetchAccessToken mgr dropboxKey++instance HasUserReq Dropbox where+ userReq _ mgr at = do+ re <- parseResponseJSON <$> authPostBS3 mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Dropbox where+ authUri _ = createCodeUri dropboxKey [ ("state", "Dropbox.test-state-123")+ ]++newtype DropboxName = DropboxName { displayName :: Text }+ deriving (Show, Generic)++data DropboxUser = DropboxUser { email :: Text+ , name :: DropboxName+ } deriving (Show, Generic)++instance FromJSON DropboxName where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++instance FromJSON DropboxUser where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://api.dropboxapi.com/2/users/get_current_account|]++toLoginUser :: DropboxUser -> LoginUser+toLoginUser ouser = LoginUser { loginUserName = displayName $ name ouser }
+ example/IDP/Facebook.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Facebook where+import Data.Aeson+import Data.Aeson.Types+import Data.Bifunctor+import Data.Hashable+import Data.Text.Lazy (Text)+import GHC.Generics+import Keys+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils++data Facebook = Facebook deriving (Show, Generic)++instance Hashable Facebook++instance IDP Facebook++instance HasLabel Facebook++instance HasTokenReq Facebook where+ tokenReq _ mgr = fetchAccessToken2 mgr facebookKey++instance HasUserReq Facebook where+ userReq _ mgr at = do+ re <- authGetJSON mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Facebook where+ authUri _ = createCodeUri facebookKey [ ("state", "Facebook.test-state-123")+ , ("scope", "user_about_me,email")+ ]++data FacebookUser = FacebookUser { id :: Text+ , name :: Text+ , email :: Text+ } deriving (Show, Generic)++instance FromJSON FacebookUser where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://graph.facebook.com/me?fields=id,name,email|]++toLoginUser :: FacebookUser -> LoginUser+toLoginUser ouser = LoginUser { loginUserName = name ouser }
+ example/IDP/Fitbit.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Fitbit where+import Control.Monad (mzero)+import Data.Aeson+import Data.Bifunctor+import Data.Hashable+import Data.Text.Lazy (Text)+import GHC.Generics+import Keys+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils+++data Fitbit = Fitbit deriving (Show, Generic)++instance Hashable Fitbit++instance IDP Fitbit++instance HasLabel Fitbit++instance HasTokenReq Fitbit where+ tokenReq _ mgr = fetchAccessToken mgr fitbitKey++instance HasUserReq Fitbit where+ userReq _ mgr at = do+ re <- authGetJSON mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Fitbit where+ authUri _ = createCodeUri fitbitKey [ ("state", "Fitbit.test-state-123")+ , ("scope", "profile")+ ]++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+++userInfoUri :: URI+userInfoUri = [uri|https://api.fitbit.com/1/user/-/profile.json|]++toLoginUser :: FitbitUser -> LoginUser+toLoginUser ouser = LoginUser { loginUserName = userName ouser }
+ example/IDP/Github.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Github where+import Data.Aeson+import Data.Aeson.Types+import Data.Bifunctor+import Data.Hashable+import Data.Text.Lazy (Text)+import GHC.Generics+import Keys+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils++data Github = Github deriving (Show, Generic)++instance Hashable Github++instance IDP Github++instance HasLabel Github++instance HasTokenReq Github where+ tokenReq _ mgr = fetchAccessToken mgr githubKey++instance HasUserReq Github where+ userReq _ mgr at = do+ re <- authGetJSON mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Github where+ authUri _ = createCodeUri githubKey [("state", "Github.test-state-123")]++data GithubUser = GithubUser { name :: Text+ , id :: Integer+ } deriving (Show, Generic)++instance FromJSON GithubUser where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://api.github.com/user|]++toLoginUser :: GithubUser -> LoginUser+toLoginUser guser = LoginUser { loginUserName = name guser }
+ example/IDP/Google.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Google where+import Data.Aeson+import Data.Aeson.Types+import Data.Bifunctor+import Data.Hashable+import Data.Text.Lazy (Text)+import GHC.Generics+import Keys+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils++data Google = Google deriving (Show, Generic)++instance Hashable Google++instance IDP Google++instance HasLabel Google++instance HasTokenReq Google where+ tokenReq _ mgr = fetchAccessToken mgr googleKey++instance HasUserReq Google where+ userReq _ mgr at = do+ re <- authGetJSON mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Google where+ authUri _ = createCodeUri googleKey [ ("state", "Google.test-state-123")+ , ("scope", "https://www.googleapis.com/auth/userinfo.email")+ ]++data GoogleUser = GoogleUser { name :: Text+ , id :: Text+ } deriving (Show, Generic)++instance FromJSON GoogleUser where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://www.googleapis.com/oauth2/v2/userinfo|]++toLoginUser :: GoogleUser -> LoginUser+toLoginUser guser = LoginUser { loginUserName = name guser }+
+ example/IDP/Linkedin.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++{-+ disabled since it's not yet working. error:+ - serviceErrorCode:100+ - message:Not enough permissions to access /me GET+-}+module IDP.Linkedin where+import Data.Aeson+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import GHC.Generics+import Types+import URI.ByteString+import URI.ByteString.QQ++data LinkedinUser = LinkedinUser { firstName :: Text+ , lastName :: Text+ } deriving (Show, Generic)++instance FromJSON LinkedinUser where+ parseJSON = genericParseJSON defaultOptions++userInfoUri :: URI+userInfoUri = [uri|https://api.linkedin.com/v2/me|]+++toLoginUser :: LinkedinUser -> LoginUser+toLoginUser LinkedinUser {..} = LoginUser { loginUserName = firstName `TL.append` " " `TL.append` lastName }++{-+mkIDPData Linkedin =+ let userUri = createCodeUri linkedinKey [("state", "linkedin.test-state-123")]+ in+ IDPData { codeFlowUri = userUri+ , loginUser = Nothing+ , idpName = Linkedin+ , oauth2Key = linkedinKey+ , toFetchAccessToken = postAT+ , userApiUri = ILinkedin.userInfoUri+ , toLoginUser = ILinkedin.toLoginUser+ }+-}
+ example/IDP/Okta.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Okta where+import Data.Aeson+import Data.Aeson.Types+import Data.Bifunctor+import Data.Hashable+import Data.Text.Lazy (Text)+import GHC.Generics+import Keys+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils++data Okta = Okta deriving (Show, Generic)++instance Hashable Okta++instance IDP Okta++instance HasLabel Okta++instance HasTokenReq Okta where+ tokenReq _ mgr = fetchAccessToken mgr oktaKey++instance HasUserReq Okta where+ userReq _ mgr at = do+ re <- authGetJSON mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Okta where+ authUri _ = createCodeUri oktaKey [ ("state", "Okta.test-state-123")+ , ("scope", "openid profile")+ ]++data OktaUser = OktaUser { name :: Text+ , preferredUsername :: Text+ } deriving (Show, Generic)++instance FromJSON OktaUser where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://dev-148986.oktapreview.com/oauth2/v1/userinfo|]++toLoginUser :: OktaUser -> LoginUser+toLoginUser ouser = LoginUser { loginUserName = name ouser }+
+ example/IDP/StackExchange.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++{-+ NOTES: stackexchange API spec and its document just sucks!+-}+module IDP.StackExchange where+import Data.Aeson+import Data.Aeson.Types+import Data.Bifunctor+import Data.ByteString (ByteString)+import Data.Hashable+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import GHC.Generics+import Keys+import Lens.Micro+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils++data StackExchange = StackExchange deriving (Show, Generic)++instance Hashable StackExchange++instance IDP StackExchange++instance HasLabel StackExchange++instance HasTokenReq StackExchange where+ tokenReq _ mgr = fetchAccessToken2 mgr stackexchangeKey++instance HasUserReq StackExchange where+ userReq _ mgr token = do+ re <- parseResponseJSON+ <$> authGetBS2 mgr token+ (userInfoUri `appendStackExchangeAppKey` stackexchangeAppKey)+ return (second toLoginUser re)++instance HasAuthUri StackExchange where+ authUri _ = createCodeUri stackexchangeKey [ ("state", "StackExchange.test-state-123")+ ]++data StackExchangeResp = StackExchangeResp { hasMore :: Bool+ , quotaMax :: Integer+ , quotaRemaining :: Integer+ , items :: [StackExchangeUser]+ } deriving (Show, Generic)++data StackExchangeUser = StackExchangeUser { userId :: Integer+ , displayName :: Text+ , profileImage :: Text+ } deriving (Show, Generic)++instance FromJSON StackExchangeResp where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }+instance FromJSON StackExchangeUser where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://api.stackexchange.com/2.2/me?site=stackoverflow|]++toLoginUser :: StackExchangeResp -> LoginUser+toLoginUser StackExchangeResp {..} =+ case items of+ [] -> LoginUser { loginUserName = TL.pack "Cannot find stackexchange user" }+ (user:_) -> LoginUser { loginUserName = displayName user }++appendStackExchangeAppKey :: URI -> ByteString -> URI+appendStackExchangeAppKey useruri k =+ over (queryL . queryPairsL) (\query -> query ++ [("key", k)]) useruri+
+ example/IDP/Weibo.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Weibo where+import Data.Aeson+import Data.Aeson.Types+import Data.Bifunctor+import Data.Hashable+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import GHC.Generics+import Keys+import Network.OAuth.OAuth2+import Types+import URI.ByteString+import URI.ByteString.QQ+import Utils++data Weibo = Weibo deriving (Show, Generic)++instance Hashable Weibo++instance IDP Weibo++instance HasLabel Weibo++instance HasTokenReq Weibo where+ tokenReq _ mgr = fetchAccessToken mgr weiboKey++-- fetch user info via+-- GET+-- access token in query param only+instance HasUserReq Weibo where+ userReq _ mgr at = do+ re <- parseResponseJSON <$> authGetBS2 mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Weibo where+ authUri _ = createCodeUri weiboKey [ ("state", "Weibo.test-state-123")+ ]++-- TODO: http://open.weibo.com/wiki/2/users/show+data WeiboUser = WeiboUser { id :: Integer+ , name :: Text+ , screenName :: Text+ } deriving (Show, Generic)++newtype WeiboUID = WeiboUID { uid :: Integer }+ deriving (Show, Generic)++instance FromJSON WeiboUID where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }+instance FromJSON WeiboUser where+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://api.weibo.com/2/account/get_uid.json|]++toLoginUser :: WeiboUID -> LoginUser+toLoginUser ouser = LoginUser { loginUserName = TL.pack $ show $ uid ouser }
example/Keys.hs view
@@ -3,13 +3,14 @@ module Keys where +import Data.ByteString (ByteString) import Network.OAuth.OAuth2 import URI.ByteString.QQ weiboKey :: OAuth2 weiboKey = OAuth2 { oauthClientId = "1962132691" , oauthClientSecret = "a2ad30383bdff9bcb12be6a3d30deeb1"- , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|]+ , oauthCallback = Just [uri|http://127.0.0.1:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|] , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|] }@@ -18,7 +19,7 @@ githubKey :: OAuth2 githubKey = OAuth2 { oauthClientId = "bf86d338485a96a93c88" , oauthClientSecret = "a1c00dada665dc00aa6fafe0495c7c885f82d1ce"- , oauthCallback = Just [uri|http://127.0.0.1:9988/githubCallback|]+ , oauthCallback = Just [uri|http://127.0.0.1:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|] , oauthAccessTokenEndpoint = [uri|https://github.com/login/oauth/access_token|] }@@ -27,7 +28,7 @@ googleKey :: OAuth2 googleKey = OAuth2 { oauthClientId = "886894027376.apps.googleusercontent.com" , oauthClientSecret = "27w98gwGB1h8N5a6JQ2bT_nm"- , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|]+ , oauthCallback = Just [uri|http://127.0.0.1:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|] , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|] }@@ -49,15 +50,15 @@ facebookKey :: OAuth2 facebookKey = OAuth2 { oauthClientId = "414630782030965" , oauthClientSecret = "0e648eae100da4d03f16594f231fc1d0"- , oauthCallback = Just [uri|http://t.haskellcn.org/cb|]+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|]- , oauthAccessTokenEndpoint = [uri|https://graph.facebook.com/v2.3/oauth/access_token|]+ , oauthAccessTokenEndpoint = [uri|https://graph.facebook.com/v2.12/oauth/access_token|] } doubanKey :: OAuth2 doubanKey = OAuth2 { oauthClientId = "02a914cf299ca31607fb3e6d7cd5e942" , oauthClientSecret = "3c0fdef13b0dd271"- , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|]+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|] , oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|] }@@ -70,12 +71,15 @@ , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|] } +stackexchangeAppKey :: ByteString+stackexchangeAppKey = "LZvAveRFYw8lgNluEU2pDQ(("+ stackexchangeKey :: OAuth2 stackexchangeKey = OAuth2 { oauthClientId = "7185" , oauthClientSecret = "K5hK)ET*dbFGFmNFVtqIyA(("- , oauthCallback = Just [uri|http://c.haskellcn.org/cb|]+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|]- , oauthAccessTokenEndpoint = [uri|https://stackexchange.com/oauth/access_token|]+ , oauthAccessTokenEndpoint = [uri|https://stackexchange.com/oauth/access_token/json|] } dropboxKey :: OAuth2@@ -93,3 +97,12 @@ , oauthOAuthorizeEndpoint = [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|] , oauthAccessTokenEndpoint = [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|] }++linkedinKey :: OAuth2+linkedinKey = OAuth2 { oauthClientId = "86r7dx3b0piy56"+ , oauthClientSecret = "lBb5kA5lpggHT0Ne"+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+ , oauthOAuthorizeEndpoint = [uri|https://www.linkedin.com/oauth/v2/authorization|]+ , oauthAccessTokenEndpoint = [uri|https://www.linkedin.com/oauth/v2/accessToken|]+ }+
example/Keys.hs.sample view
@@ -3,6 +3,7 @@ module Keys where +import Data.ByteString (ByteString) import Network.OAuth.OAuth2 import URI.ByteString.QQ @@ -55,6 +56,11 @@ , oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|] , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|] }++-- fix key from your application edit page+-- https://stackapps.com/apps/oauth+stackexchangeAppKey :: ByteString+stackexchangeAppKey = "xxxxxx" stackexchangeKey :: OAuth2 stackexchangeKey = OAuth2 { oauthClientId = "xx"
− example/Okta/test.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module Main where--import Data.Aeson-import Data.Aeson.Types-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.Text as T-import GHC.Generics-import Network.HTTP.Conduit-import qualified Network.HTTP.Types as HT-import URI.ByteString-import URI.ByteString.QQ--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'- $ appendQueryParams [("scope", "openid profile"), ("state", "test-state-123")]- $ authorizationUrl oktaKey- putStrLn "visit the url and paste code here: "- code <- getLine- mgr <- newManager tlsManagerSettings- token <- fetchAccessToken mgr oktaKey (ExchangeToken (T.pack code))- print token- case token of- Right at -> getUserInfo mgr (accessToken at) >>= print- Left _ -> putStrLn "no access token found yet"--getUserInfo :: Manager -> AccessToken -> IO (OAuth2Result Errors BSL.ByteString)-getUserInfo mgr token =- authGetBS mgr token [uri|https://dev-148986.oktapreview.com/oauth2/v1/userinfo|]
+ example/README.md view
@@ -0,0 +1,13 @@+* IDPs+ - douban: http://developers.douban.com/wiki/?title=oauth2+ - Google: <https://developers.google.com/accounts/docs/OAuth2WebServer>+ - Github: <http://developer.github.com/v3/oauth/>+ - Facebook: <http://developers.facebook.com/docs/facebook-login/>+ - Fitbit: <http://dev.fitbit.com/docs/oauth2/>+ - StackExchange: <https://api.stackexchange.com/docs/authentication>+ - StackExchange Apps page: <https://stackapps.com/apps/oauth>+ - DropBox: <https://www.dropbox.com/developers/reference/oauth-guide>+ - Weibo: <http://open.weibo.com/wiki/Oauth2>++** Linkedin+ - <https://developer.linkedin.com>
+ example/Session.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RankNTypes #-}++{- mimic server side session store -}++module Session where++import Control.Concurrent.MVar+import qualified Data.HashMap.Strict as Map++import Types++initCacheStore :: IO CacheStore+initCacheStore = newMVar Map.empty++allValues :: CacheStore -> IO [IDPData]+allValues store = do+ m1 <- tryReadMVar store+ return $ maybe [] Map.elems m1++removeKey :: CacheStore -> IDPLabel -> IO ()+removeKey store idpKey = do+ m1 <- takeMVar store+ let m2 = Map.update updateIdpData idpKey m1+ putMVar store m2+ where updateIdpData idpD = Just $ idpD { loginUser = Nothing }++lookupKey :: CacheStore+ -> IDPLabel+ -> IO (Maybe IDPData)+lookupKey store idpKey = do+ m1 <- tryReadMVar store+ return $ maybe Nothing (Map.lookup idpKey) m1++insertIDPData :: CacheStore -> IDPData -> IO ()+insertIDPData store val = do+ m1 <- takeMVar store+ let m2 = Map.insert (idpDisplayLabel val) val m1+ putMVar store m2
− example/StackExchange/test.hs
@@ -1,94 +0,0 @@-{-# 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
+ example/Types.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Types where++import Control.Concurrent.MVar+import Data.Aeson+import Data.Aeson.Types+import Data.Hashable+import qualified Data.HashMap.Strict as Map+import Data.Maybe+import Data.Text.Lazy+import qualified Data.Text.Lazy as TL+import GHC.Generics+import Network.HTTP.Conduit+import Network.OAuth.OAuth2+import qualified Network.OAuth.OAuth2.TokenRequest as TR+import Text.Mustache+import qualified Text.Mustache as M++type IDPLabel = Text++-- TODO: how to make following type work??+-- type CacheStore = forall a. IDP a => MVar (Map.HashMap a IDPData)+type CacheStore = MVar (Map.HashMap IDPLabel IDPData)++-- * type class for defining a IDP+--+class (Hashable a, Show a) => IDP a++class (IDP a) => HasLabel a where+ idpLabel :: a -> IDPLabel+ idpLabel = TL.pack . show++class (IDP a) => HasAuthUri a where+ authUri :: a -> Text++class (IDP a) => HasTokenReq a where+ tokenReq :: a -> Manager -> ExchangeToken -> IO (OAuth2Result TR.Errors OAuth2Token)++class (IDP a) => HasUserReq a where+ userReq :: FromJSON b => a -> Manager -> AccessToken -> IO (OAuth2Result b LoginUser)++data IDPApp = forall a. (IDP a, HasTokenReq a, HasUserReq a, HasLabel a, HasAuthUri a) => IDPApp a++-- dummy oauth2 request error+--+data Errors =+ SomeRandomError+ deriving (Show, Eq, Generic)++instance FromJSON Errors where+ parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }++newtype LoginUser =+ LoginUser { loginUserName :: Text+ } deriving (Eq, Show)++data IDPData =+ IDPData { codeFlowUri :: Text+ , loginUser :: Maybe LoginUser+ , idpDisplayLabel :: IDPLabel+ }++-- simplify use case to only allow one idp instance for now.+instance Eq IDPData where+ a == b = idpDisplayLabel a == idpDisplayLabel b++instance Ord IDPData where+ a `compare` b = idpDisplayLabel a `compare` idpDisplayLabel b++newtype TemplateData = TemplateData { idpTemplateData :: [IDPData]+ } deriving (Eq)++-- * Mustache instances+instance ToMustache IDPData where+ toMustache t' = M.object+ [ "codeFlowUri" ~> codeFlowUri t'+ , "isLogin" ~> isJust (loginUser t')+ , "user" ~> loginUser t'+ , "name" ~> TL.unpack (idpDisplayLabel t')+ ]++instance ToMustache LoginUser where+ toMustache t' = M.object+ [ "name" ~> loginUserName t' ]++instance ToMustache TemplateData where+ toMustache td' = M.object+ [ "idps" ~> idpTemplateData td'+ ]
+ example/Utils.hs view
@@ -0,0 +1,34 @@+module Utils where++import qualified Data.Aeson as Aeson+import Data.ByteString (ByteString)+import qualified Data.Text.Encoding as TE+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL+import Network.OAuth.OAuth2+import URI.ByteString+import Web.Scotty.Internal.Types++tlToBS :: TL.Text -> ByteString+tlToBS = TE.encodeUtf8 . TL.toStrict++paramValue :: Text -> [Param] -> [Text]+paramValue key = fmap snd . filter (hasParam key)++hasParam :: Text -> Param -> Bool+hasParam t = (== t) . fst++parseValue :: Aeson.FromJSON a => Maybe Aeson.Value -> Maybe a+parseValue Nothing = Nothing+parseValue (Just a) = case Aeson.fromJSON a of+ Aeson.Error _ -> Nothing+ Aeson.Success b -> Just b++createCodeUri :: OAuth2+ -> [(ByteString, ByteString)]+ -> Text+createCodeUri key params = TL.fromStrict $ TE.decodeUtf8 $ serializeURIRef'+ $ appendQueryParams params+ $ authorizationUrl key++
+ example/Views.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++module Views where++import Control.Monad.IO.Class (liftIO)+import Data.List (sort)+import qualified Data.Text.Lazy as TL+import Text.Mustache+import Text.Parsec.Error+import Web.Scotty++import Types++type CookieUser = String++tpl :: FilePath -> IO (Either ParseError Template)+tpl f = automaticCompile ["./example/templates", "./templates"] (f ++ ".mustache")++tplS :: FilePath+ -> [IDPData]+ -> IO TL.Text+tplS path xs = do+ template <- tpl path+ case template of+ Left e -> return+ $ TL.unlines+ $ map TL.pack [ "can not parse template " ++ path ++ ".mustache" , show e ]+ Right t' -> return $ TL.fromStrict $ substitute t' (TemplateData $ sort xs)++tplH :: FilePath+ -> [IDPData]+ -> ActionM ()+tplH path xs = do+ s <- liftIO (tplS path xs)+ html s+++overviewTpl :: [IDPData] -> ActionM ()+overviewTpl = tplH "index"
− example/Weibo/test.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--{---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 Data.Aeson-import Data.Aeson.Types-import GHC.Generics--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
+ example/assets/main.css view
@@ -0,0 +1,11 @@+body {+ padding: 10px 50px;+}++.login-with {+ margin: 10px 0;+ padding: 10px;+ border: 1px solid grey;+ border-radius: 5px;+ width: 500px;+}
− example/demo-server.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# 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 Data.Aeson-import Data.Aeson.Types-import GHC.Generics----------------------------------------------------------------------------------main :: IO ()-main = do- print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey- putStrLn "visit the url to continue"- run 9988 application--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--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/main.hs view
@@ -0,0 +1,6 @@+module Main where++import App (app)++main :: IO ()+main = app
+ example/templates/index.mustache view
@@ -0,0 +1,30 @@+<html>+ <head>+ <link href="/main.css" rel="stylesheet"/>+ </head>+ <body>+ <h1>Hello OAuth2</h1>+ {{#idps}}+ <section class="login-with">++ {{^isLogin}}+ <a href="{{codeFlowUri}}">Login {{name}}</a>+ {{/isLogin}}++ {{#isLogin}}+ <h2>Welcome to {{name}}</h2>+ {{#user}}+ <div class="result">Hello, {{name}}</div>+ {{/user}}+ <a href="/logout?idp={{name}}">Logout</a>+ {{/isLogin}}++ </section>+ {{/idps}}+ <h2>Notes</h2>+ <ol>+ <li>for StackExchange, the callback domain is localhost, have manually add port 9988.</li>+ </ol>+ </p>+ </body>+</html>
hoauth2.cabal view
@@ -1,6 +1,6 @@ Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy-Version: 1.6.3+Version: 1.7.0 Synopsis: Haskell OAuth2 authentication client @@ -35,12 +35,23 @@ 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+ example/IDP/Google.hs+ example/IDP/Weibo.hs+ example/IDP/Github.hs+ example/IDP/Facebook.hs+ example/IDP/Fitbit.hs+ example/IDP/Douban.hs+ example/IDP/Linkedin.hs+ example/IDP.hs+ example/App.hs+ example/Session.hs+ example/Types.hs+ example/Utils.hs+ example/Views.hs+ example/main.hs+ example/README.md+ example/templates/index.mustache+ example/assets/main.css Cabal-version: >=1.10 @@ -79,245 +90,30 @@ 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- other-modules: Keys- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- http-types >= 0.11 && < 0.13,- http-conduit >= 2.1 && < 2.4,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- 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- other-modules: Keys- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- http-types >= 0.11 && < 0.13,- http-conduit >= 2.1 && < 2.4,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- 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- other-modules: Keys- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- http-types >= 0.11 && < 0.13,- http-conduit >= 2.1 && < 2.4,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- 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- other-modules: Keys- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- http-types >= 0.11 && < 0.13,- http-conduit >= 2.1 && < 2.4,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- 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- other-modules: Keys- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- http-types >= 0.11 && < 0.13,- http-conduit >= 2.1 && < 2.4,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- 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- other-modules: Keys- 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.4,- http-conduit >= 2.1 && < 2.4,- http-types >= 0.11 && < 0.13,- 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- other-modules: Keys- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- http-types >= 0.11 && < 0.13,- http-conduit >= 2.1 && < 2.4,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- 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- other-modules: Keys- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- http-types >= 0.11 && < 0.13,- http-conduit >= 2.1 && < 2.4,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- 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-okta- if flag(test)- Buildable: True- else- Buildable: False-- main-is: Okta/test.hs- other-modules: Keys- hs-source-dirs: example- default-language: Haskell2010- build-depends: base >= 4.5 && < 5,- http-types >= 0.11 && < 0.13,- http-conduit >= 2.1 && < 2.4,- text >= 0.11 && < 1.3,- bytestring >= 0.9 && < 0.11,- uri-bytestring >= 0.2.3.1 && < 0.4,- 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 demo-server if flag(test) Buildable: True else Buildable: False - main-is: demo-server.hs- other-modules: Keys+ main-is: main.hs+ other-modules: IDP,+ App+ IDP.Douban+ IDP.Dropbox+ IDP.Facebook+ IDP.Fitbit+ IDP.Github+ IDP.Google+ IDP.Okta+ IDP.StackExchange+ IDP.Weibo+ IDP.Linkedin+ Keys+ Session+ Types+ Utils+ Views hs-source-dirs: example default-language: Haskell2010 build-depends: base >= 4.5 && < 5,@@ -330,8 +126,17 @@ warp >= 3.2 && < 3.3, containers >= 0.4 && < 0.6, aeson >= 0.11 && < 1.3,- hoauth2-+ microlens >= 0.4.0 && < 0.5,+ unordered-containers >= 0.2.8 && < 0.2.9,+ wai-extra >= 3.0.21.0 && < 3.0.22.0,+ wai-middleware-static == 0.8.1,+ mustache >= 2.2.3 && < 2.3.0,+ mtl >= 2.2.1 && < 2.3,+ scotty == 0.10.0,+ binary >= 0.8.3.0 && < 0.8.5,+ parsec >= 3.1.11 && < 3.2.0 ,+ hashable >= 1.2.6 && < 1.3.0,+ hoauth2 >= 1.6 && < 1.7 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
src/Network/OAuth/OAuth2/HttpClient.hs view
@@ -7,17 +7,20 @@ module Network.OAuth.OAuth2.HttpClient ( -- * Token management fetchAccessToken,+ fetchAccessToken2, fetchRefreshToken,+ refreshAccessToken, doJSONPostRequest, doFlexiblePostRequest, doSimplePostRequest, -- * AUTH requests authGetJSON, authGetBS,- authGetBS',+ authGetBS2, authPostJSON, authPostBS,- authPostBS',+ authPostBS2,+ authPostBS3, authRequest, -- * Utilities handleResponse,@@ -44,7 +47,9 @@ -- * Token management -------------------------------------------------- --- | Request (via POST method) "OAuth2 Token".+-- | Request OAuth2 Token+-- method: POST+-- authenticate in header fetchAccessToken :: Manager -- ^ HTTP connection manager -> OAuth2 -- ^ OAuth Data -> ExchangeToken -- ^ OAuth 2 Tokens@@ -52,17 +57,36 @@ fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code +-- | Request OAuth2 Token+-- method: POST+-- authenticate in both header and body+fetchAccessToken2 :: Manager -- ^ HTTP connection manager+ -> OAuth2 -- ^ OAuth Data+ -> ExchangeToken -- ^ OAuth 2 Tokens+ -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token+fetchAccessToken2 mgr oa code = do+ let (url, body1) = accessTokenUrl oa code+ let extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId oa)+ , ("client_secret", T.encodeUtf8 $ oauthClientSecret oa)+ ]+ doFlexiblePostRequest mgr oa url (extraBody ++ body1) -- | Request a new AccessToken with the Refresh Token.--- TODO: seems more approporate to rename to refreshAccessToken-fetchRefreshToken :: Manager -- ^ HTTP connection manager.+refreshAccessToken :: 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+refreshAccessToken manager oa token = doFlexiblePostRequest manager oa uri body where (uri, body) = refreshAccessTokenUrl oa token +{-# DEPRECATED fetchRefreshToken "Use refreshAccessToken" #-}+fetchRefreshToken :: Manager -- ^ HTTP connection manager.+ -> OAuth2 -- ^ OAuth context+ -> RefreshToken -- ^ refresh token gained after authorization+ -> IO (OAuth2Result TR.Errors OAuth2Token)+fetchRefreshToken = refreshAccessToken + -- | Conduct post request and return response as JSON. doJSONPostRequest :: FromJSON err => FromJSON a => Manager -- ^ HTTP connection manager.@@ -117,12 +141,13 @@ 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.+authGetBS2 :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString-authGetBS' manager token url = do+authGetBS2 manager token url = do req <- uriToRequest (url `appendAccessToken` token)+ -- print $ queryString req authRequest req upReq manager where upReq = updateRequestHeaders Nothing . setMethod HT.GET @@ -149,16 +174,28 @@ upReq = upHeaders . upBody -- | Conduct POST request with access token in the request body rather header-authPostBS' :: FromJSON err => Manager -- ^ HTTP connection manager.+authPostBS2 :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString-authPostBS' manager token url pb = do+authPostBS2 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++-- | Conduct POST request with access token in the header and null in body+authPostBS3 :: FromJSON err => Manager -- ^ HTTP connection manager.+ -> AccessToken+ -> URI+ -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString+authPostBS3 manager token url = do+ req <- uriToRequest url+ authRequest req upReq manager+ where upBody req = req { requestBody = "null" }+ upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST upReq = upHeaders . upBody -- |Send an HTTP request including the Authorization header with the specified