hoauth2 1.16.0 → 1.16.1
raw patch · 13 files changed
+656/−431 lines, 13 filesdep −containersdep −mtldep −wai-extradep ~hashablePVP ok
version bump matches the API change (PVP)
Dependencies removed: containers, mtl, wai-extra
Dependency ranges changed: hashable
API changes (from Hackage documentation)
Files
- README.md +4/−3
- example/App.hs +71/−45
- example/IDP.hs +29/−28
- example/IDP/Auth0.hs +63/−0
- example/IDP/Okta.hs +18/−10
- example/IDP/Weibo.hs +32/−25
- example/Keys.hs +119/−78
- example/Keys.hs.sample +94/−67
- example/README.md +0/−19
- example/README.org +26/−0
- example/Types.hs +60/−51
- hoauth2.cabal +5/−6
- src/Network/OAuth/OAuth2/Internal.hs +135/−99
README.md view
@@ -3,14 +3,15 @@ # Introduction -A lightweight oauth2 haskell binding.+A lightweight OAuth2 Haskell binding. -# Build example app+# Build the sample App +- Make sure `ghc-8.10` and `cabal-3.x` installed. - `make create-keys` - check the `example/Keys.hs` to make sure it's config correctly for the IdP you're going to test. (client id, client secret, oauth Urls etc) - `make build`-- `make demo`+- `make start-demo` - open <http://localhost:9988> ## Nix
example/App.hs view
@@ -5,20 +5,25 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -module App (app, waiApp) where+module App+ ( app+ , waiApp+ ) where import Control.Monad-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Class ( MonadIO+ , liftIO+ ) import Data.Bifunctor import Data.Maybe-import Data.Text.Lazy (Text)+import Data.Text.Lazy ( Text ) import qualified Data.Text.Lazy as TL import IDP 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.Handler.Warp ( run ) import Network.Wai.Middleware.Static import Prelude import Session@@ -35,9 +40,10 @@ myServerPort = 9988 app :: IO ()-app = putStrLn ("Starting Server. http://localhost:" ++ show myServerPort)- >> waiApp- >>= run myServerPort+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@@ -78,34 +84,35 @@ case eitherIdpApp of Right (IDPApp idp) -> do maybeIdpData <- lookIdp c idp- when (isNothing maybeIdpData) (raise "refreshH: cannot find idp data from cache")+ when (isNothing maybeIdpData)+ (raise "refreshH: cannot find idp data from cache") let idpData = fromJust maybeIdpData re <- liftIO $ doRefreshToken idp idpData case re of Right newToken -> liftIO (print newToken) >> redirectToHomeM -- TODO: update access token in the store- Left e -> raise (TL.pack e)- Left e -> raise ("logout: unknown IDP " `TL.append` e)+ Left e -> raise (TL.pack e)+ Left e -> raise ("logout: unknown IDP " `TL.append` e) -doRefreshToken :: HasTokenRefreshReq a =>- a -> IDPData -> IO (Either String OAuth2Token)+doRefreshToken+ :: HasTokenRefreshReq a => a -> IDPData -> IO (Either String OAuth2Token) doRefreshToken idp idpData = do mgr <- newManager tlsManagerSettings case oauth2Token idpData of Nothing -> return $ Left "no token found for idp"- Just at ->- case refreshToken at of- Nothing -> return $ Left "no refresh token presents"- Just rt -> do- re <- tokenRefreshReq idp mgr rt- return (first show re)+ Just at -> case refreshToken at of+ Nothing -> return $ Left "no refresh token presents"+ Just rt -> do+ re <- tokenRefreshReq idp mgr rt+ return (first show re) logoutH :: CacheStore -> ActionM () logoutH c = do eitherIdpApp <- readIdpParam -- let eitherIdpApp = parseIDP (head idpP) case eitherIdpApp of- Right (IDPApp idp) -> liftIO (removeKey c (idpLabel idp)) >> redirectToHomeM- Left e -> raise ("logout: unknown IDP " `TL.append` e)+ Right (IDPApp idp) ->+ liftIO (removeKey c (idpLabel idp)) >> redirectToHomeM+ Left e -> raise ("logout: unknown IDP " `TL.append` e) indexH :: CacheStore -> ActionM () indexH c = liftIO (allValues c) >>= overviewTpl@@ -113,68 +120,87 @@ callbackH :: CacheStore -> ActionM () callbackH c = do pas <- params- let codeP = paramValue "code" pas+ let codeP = paramValue "code" pas let stateP = paramValue "state" pas- when (null codeP) (raise "callbackH: no code from callback request")+ when (null codeP) (raise "callbackH: no code from callback request") when (null stateP) (raise "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 -> raise ("callbackH: cannot find IDP name from text " `TL.append` e)+ Left e ->+ raise ("callbackH: cannot find IDP name from text " `TL.append` e) -fetchTokenAndUser :: (HasTokenReq a, HasUserReq a, HasLabel a)- => CacheStore- -> TL.Text -- ^ code- -> a- -> ActionM ()+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) (raise "fetchTokenAndUser: cannot find idp data from cache")+ when (isNothing maybeIdpData)+ (raise "fetchTokenAndUser - cannot find idp data from cache") let idpData = fromJust maybeIdpData result <- liftIO $ fetchTokenAndUser' c code idp idpData case result of- Right _ -> redirectToHomeM- Left err -> raise err+ Right _ -> redirectToHomeM+ Left err -> raise err -fetchTokenAndUser' :: (HasTokenReq a, HasUserReq a) =>- CacheStore -> Text -> a -> IDPData -> IO (Either Text ())+fetchTokenAndUser'+ :: (HasTokenReq a, HasUserReq a)+ => CacheStore+ -> Text+ -> a+ -> IDPData+ -> IO (Either Text ()) fetchTokenAndUser' c code idp idpData = do- mgr <- newManager tlsManagerSettings+ mgr <- newManager tlsManagerSettings token <- tokenReq idp mgr (ExchangeToken $ TL.toStrict code) when debug (print token) result <- case token of Right at -> tryFetchUser mgr at idp- Left e -> return (Left $ TL.pack $ "tryFetchUser: cannot fetch asses token. error detail: " ++ show e)+ Left e -> return+ ( Left+ $ TL.pack+ $ "tryFetchUser - cannot fetch asses token. error detail: "+ ++ show e+ ) case result of Right (luser, at) -> updateIdp c idpData luser at >> return (Right ())- Left err -> return $ Left ("fetchTokenAndUser: " `TL.append` err)+ Left err ->+ return $ Left ("fetchTokenAndUser - no user found: " `TL.append` err) - where updateIdp c1 oldIdpData luser token =- insertIDPData c1 (oldIdpData {loginUser = Just luser, oauth2Token = Just token })+ where+ updateIdp c1 oldIdpData luser token = insertIDPData+ c1+ (oldIdpData { loginUser = Just luser, oauth2Token = Just token }) -lookIdp :: (MonadIO m, HasLabel a) =>- CacheStore -> a -> m (Maybe IDPData)+lookIdp :: (MonadIO m, HasLabel a) => CacheStore -> a -> m (Maybe IDPData) lookIdp c1 idp1 = liftIO $ lookupKey c1 (idpLabel idp1) -- TODO: may use Exception monad to capture error in this IO monad ---tryFetchUser :: HasUserReq a =>- Manager- -> OAuth2Token -> a -> IO (Either Text (LoginUser, OAuth2Token))+tryFetchUser+ :: HasUserReq a+ => Manager+ -> OAuth2Token+ -> a+ -> IO (Either Text (LoginUser, OAuth2Token)) tryFetchUser mgr at idp = do re <- fetchUser idp mgr (accessToken at) return $ case re of Right user' -> Right (user', at)- Left e -> Left e+ Left e -> Left e -- * Fetch UserInfo ---fetchUser :: (HasUserReq a) => a -> Manager -> AccessToken -> IO (Either Text LoginUser)+fetchUser+ :: (HasUserReq a) => a -> Manager -> AccessToken -> IO (Either Text LoginUser) fetchUser idp mgr token = do re <- userReq idp mgr token return (first bslToText re)
example/IDP.hs view
@@ -1,38 +1,39 @@- module IDP where -import Data.Text.Lazy (Text)- import qualified Data.HashMap.Strict as Map-import qualified IDP.AzureAD as IAzureAD-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 qualified IDP.ZOHO as IZOHO-import Session-import Types+import Data.Text.Lazy (Text)+import qualified IDP.Auth0 as IAuth0+import qualified IDP.AzureAD as IAzureAD+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 qualified IDP.ZOHO as IZOHO+import Session+import Types -- TODO: make this generic to discover any IDPs from idp directory. -- idps :: [IDPApp]-idps = [ IDPApp IAzureAD.AzureAD- , 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- , IDPApp IZOHO.ZOHO- ]+idps =+ [ IDPApp IAzureAD.AzureAD,+ 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,+ IDPApp IAuth0.Auth0,+ IDPApp IZOHO.ZOHO+ ] initIdps :: CacheStore -> IO () initIdps c = mapM_ (insertIDPData c) (fmap mkIDPData idps)
+ example/IDP/Auth0.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module IDP.Auth0 where++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 Auth0 = Auth0+ deriving (Show, Generic)++instance Hashable Auth0++instance IDP Auth0++instance HasLabel Auth0++instance HasTokenReq Auth0 where+ tokenReq _ mgr = fetchAccessToken mgr auth0Key++instance HasTokenRefreshReq Auth0 where+ tokenRefreshReq _ mgr = refreshAccessToken mgr auth0Key++instance HasUserReq Auth0 where+ userReq _ mgr at = do+ re <- authGetJSON mgr at userInfoUri+ return (second toLoginUser re)++instance HasAuthUri Auth0 where+ authUri _ =+ createCodeUri+ auth0Key+ [ ("state", "Auth0.test-state-123"),+ ( "scope",+ "openid profile email offline_access"+ )+ ]++data Auth0User = Auth0User+ { name :: Text,+ email :: Text+ }+ deriving (Show, Generic)++instance FromJSON Auth0User where+ parseJSON =+ genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}++userInfoUri :: URI+userInfoUri = [uri|https://freizl.auth0.com/userinfo|]++toLoginUser :: Auth0User -> LoginUser+toLoginUser ouser = LoginUser {loginUserName = name ouser}
example/IDP/Okta.hs view
@@ -6,7 +6,7 @@ import Data.Aeson import Data.Bifunctor import Data.Hashable-import Data.Text.Lazy (Text)+import Data.Text.Lazy ( Text ) import GHC.Generics import Keys import Network.OAuth.OAuth2@@ -15,7 +15,8 @@ import URI.ByteString.QQ import Utils -data Okta = Okta deriving (Show, Generic)+data Okta = Okta+ deriving (Show, Generic) instance Hashable Okta @@ -35,19 +36,26 @@ return (second toLoginUser re) instance HasAuthUri Okta where- authUri _ = createCodeUri oktaKey [ ("state", "Okta.test-state-123")- , ("scope", "openid profile offline_access")- ]+ authUri _ = createCodeUri+ oktaKey+ [ ("state", "Okta.test-state-123")+ , ( "scope"+ , "openid profile offline_access okta.users.read.self okta.users.read"+ )+ ] -data OktaUser = OktaUser { name :: Text- , preferredUsername :: Text- } deriving (Show, Generic)+data OktaUser = OktaUser+ { name :: Text+ , preferredUsername :: Text+ }+ deriving (Show, Generic) instance FromJSON OktaUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }+ parseJSON =+ genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } userInfoUri :: URI-userInfoUri = [uri|https://dev-148986.oktapreview.com/oauth2/v1/userinfo|]+userInfoUri = [uri|http://rain.okta1.com:1802/oauth2/v1/userinfo|] toLoginUser :: OktaUser -> LoginUser toLoginUser ouser = LoginUser { loginUserName = name ouser }
example/IDP/Weibo.hs view
@@ -1,21 +1,22 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes #-} module IDP.Weibo where-import Data.Aeson-import Data.Bifunctor++import Data.Aeson+import Data.Bifunctor import qualified Data.ByteString.Lazy.Char8 as BSL-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+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) @@ -40,25 +41,31 @@ return (re >>= (bimap BSL.pack toLoginUser . eitherDecode)) instance HasAuthUri Weibo where- authUri _ = createCodeUri weiboKey [ ("state", "Weibo.test-state-123")- ]+ 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)+-- | UserInfor API: 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 }+newtype WeiboUID = WeiboUID {uid :: Integer} deriving (Show, Generic) instance FromJSON WeiboUID where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }+ parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}+ instance FromJSON WeiboUser where- parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }+ 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 }+toLoginUser ouser = LoginUser {loginUserName = TL.pack $ show $ uid ouser}
example/Keys.hs view
@@ -1,61 +1,75 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes #-} module Keys where -import Data.ByteString (ByteString)-import Network.OAuth.OAuth2-import URI.ByteString.QQ+import Data.ByteString (ByteString)+import Network.OAuth.OAuth2+import URI.ByteString.QQ weiboKey :: OAuth2-weiboKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|]- , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]- }+weiboKey =+ OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx",+ oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx",+ oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|],+ oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|],+ oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]+ } -- | http://developer.github.com/v3/oauth/ githubKey :: OAuth2-githubKey = OAuth2 { oauthClientId = "bf86d338485a96a93c88"- , oauthClientSecret = Just "a90515a66c1de4ffcf839900bc0cda0a74d44e58"- , 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|]- }+githubKey =+ OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx",+ oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx",+ oauthCallback = Just [uri|http://127.0.0.1:9988/githubCallback|],+ oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|],+ oauthAccessTokenEndpoint =+ [uri|https://github.com/login/oauth/access_token|]+ } -- | oauthCallback = Just "https://developers.google.com/oauthplayground" googleKey :: OAuth2-googleKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx.apps.googleusercontent.com"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|]- , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|]- , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]- }+googleKey =+ OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx.apps.googleusercontent.com",+ oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx",+ oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|],+ oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|],+ oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]+ } facebookKey :: OAuth2-facebookKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://t.haskellcn.org/cb|]- , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|]- , oauthAccessTokenEndpoint = [uri|https://graph.facebook.com/v2.3/oauth/access_token|]- }+facebookKey =+ OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx",+ oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx",+ oauthCallback = Just [uri|http://t.haskellcn.org/cb|],+ oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|],+ oauthAccessTokenEndpoint =+ [uri|https://graph.facebook.com/v2.3/oauth/access_token|]+ } doubanKey :: OAuth2-doubanKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|]- , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|]- , oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]- }+doubanKey =+ OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx",+ oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx",+ oauthCallback = Just [uri|http://localhost:9999/oauthCallback|],+ oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|],+ oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]+ } fitbitKey :: OAuth2-fitbitKey = OAuth2 { oauthClientId = "xxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]- }+fitbitKey =+ OAuth2+ { oauthClientId = "xxxxxx",+ oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx",+ oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|],+ oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|],+ oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]+ } -- fix key from your application edit page -- https://stackapps.com/apps/oauth@@ -63,49 +77,76 @@ stackexchangeAppKey = "xxxxxx" stackexchangeKey :: OAuth2-stackexchangeKey = OAuth2 { oauthClientId = "xx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://c.haskellcn.org/cb|]- , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|]- , oauthAccessTokenEndpoint = [uri|https://stackexchange.com/oauth/access_token|]- }+stackexchangeKey =+ OAuth2+ { oauthClientId = "xx",+ oauthClientSecret = Just "xxxxxxxxxxxxxxx",+ oauthCallback = Just [uri|http://c.haskellcn.org/cb|],+ oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|],+ oauthAccessTokenEndpoint =+ [uri|https://stackexchange.com/oauth/access_token|]+ }+ dropboxKey :: OAuth2-dropboxKey = OAuth2 { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]- }+dropboxKey =+ OAuth2+ { oauthClientId = "xxx",+ oauthClientSecret = Just "xxx",+ oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|],+ oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|],+ oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]+ } oktaKey :: OAuth2-oktaKey = OAuth2 { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|]- , oauthAccessTokenEndpoint = [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|]- }+oktaKey =+ OAuth2+ { oauthClientId = "0oa54gpOiDEZTA2rk0g4",+ oauthClientSecret = Just "0_Vo1pBmK6tOSl25V1mEOyGDunakBCBDFGnCvHcF",+ oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|],+ oauthOAuthorizeEndpoint =+ [uri|http://rain.okta1.com:1802/oauth2/v1/authorize|],+ oauthAccessTokenEndpoint = [uri|http://rain.okta1.com:1802/oauth2/v1/token|]+ } +oktaKey1 :: OAuth2+oktaKey1 =+ OAuth2+ { oauthClientId = "0oa3pfim3hCbfCqaw0g7",+ oauthClientSecret = Just "sc0J-DXuJgB3sApT3xMr6_jS2kJ6QXhp3RxBTszo",+ oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|],+ oauthOAuthorizeEndpoint =+ [uri|https://hw2.trexcloud.com/oauth2/v1/authorize|],+ oauthAccessTokenEndpoint = [uri|https://hw2.trexcloud.com/oauth2/v1/token|]+ }+ azureADKey :: OAuth2-azureADKey = OAuth2 { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://login.windows.net/common/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://login.windows.net/common/oauth2/token|]- }+azureADKey =+ OAuth2+ { oauthClientId = "xxx",+ oauthClientSecret = Just "xxx",+ oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|],+ oauthOAuthorizeEndpoint =+ [uri|https://login.windows.net/common/oauth2/authorize|],+ oauthAccessTokenEndpoint =+ [uri|https://login.windows.net/common/oauth2/token|]+ } zohoKey :: OAuth2-zohoKey = OAuth2 { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://accounts.zoho.com/oauth/v2/auth|]- , oauthAccessTokenEndpoint = [uri|https://accounts.zoho.com/oauth/v2/token|]- }+zohoKey =+ OAuth2+ { oauthClientId = "xxx",+ oauthClientSecret = Just "xxx",+ oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|],+ oauthOAuthorizeEndpoint = [uri|https://accounts.zoho.com/oauth/v2/auth|],+ oauthAccessTokenEndpoint = [uri|https://accounts.zoho.com/oauth/v2/token|]+ } -jiraKey :: OAuth2-jiraKey = OAuth2- { oauthClientId = "Uku1UYrrthADsgLMtbe3myrP2r8EGKFk"- , oauthClientSecret = Just "tOJXIdO-fJ9afdJGMW7yksRL49HJhtZ-03kpny06489cc2MUtsdJHZOzuphmH0Gs"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://auth.atlassian.com/authorize|]- , oauthAccessTokenEndpoint = [uri|https://auth.atlassian.com/oauth/token|]- }+auth0Key :: OAuth2+auth0Key =+ OAuth2+ { oauthClientId = "tmEEsqOamfVZM3Z62vK91OQpmPQLlMAk",+ oauthClientSecret = Just "6JA_iHEjsVqsLemAMRLoUaOvL-tJSjA31o0h6qt-dXcLEfe0OSLwDHQDwX8kq3Hy",+ oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|],+ oauthOAuthorizeEndpoint = [uri|https://freizl.auth0.com/authorize|],+ oauthAccessTokenEndpoint = [uri|https://freizl.auth0.com/oauth/token|]+ }
example/Keys.hs.sample view
@@ -3,59 +3,67 @@ module Keys where -import Data.ByteString (ByteString)+import Data.ByteString ( ByteString ) import Network.OAuth.OAuth2 import URI.ByteString.QQ weiboKey :: OAuth2-weiboKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|]- , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]- }+weiboKey = OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx"+ , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just [uri|http://127.0.0.1:9988/oauthCallback|]+ , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|]+ , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]+ } -- | http://developer.github.com/v3/oauth/ githubKey :: OAuth2-githubKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/githubCallback|]- , oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|]- , oauthAccessTokenEndpoint = [uri|https://github.com/login/oauth/access_token|]- }+githubKey = OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx"+ , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just [uri|http://127.0.0.1:9988/githubCallback|]+ , oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|]+ , oauthAccessTokenEndpoint =+ [uri|https://github.com/login/oauth/access_token|]+ } -- | oauthCallback = Just "https://developers.google.com/oauthplayground" googleKey :: OAuth2-googleKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx.apps.googleusercontent.com"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|]- , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|]- , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]- }+googleKey = OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx.apps.googleusercontent.com"+ , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|]+ , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|]+ , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]+ } facebookKey :: OAuth2-facebookKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://t.haskellcn.org/cb|]- , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|]- , oauthAccessTokenEndpoint = [uri|https://graph.facebook.com/v2.3/oauth/access_token|]- }+facebookKey = OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx"+ , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just [uri|http://t.haskellcn.org/cb|]+ , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|]+ , oauthAccessTokenEndpoint =+ [uri|https://graph.facebook.com/v2.3/oauth/access_token|]+ } doubanKey :: OAuth2-doubanKey = OAuth2 { oauthClientId = "xxxxxxxxxxxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|]- , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|]- , oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]- }+doubanKey = OAuth2+ { oauthClientId = "xxxxxxxxxxxxxxx"+ , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|]+ , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|]+ , oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]+ } fitbitKey :: OAuth2-fitbitKey = OAuth2 { oauthClientId = "xxxxxx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]- }+fitbitKey = OAuth2+ { oauthClientId = "xxxxxx"+ , oauthClientSecret = Just "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+ , oauthOAuthorizeEndpoint = [uri|https://www.fitbit.com/oauth2/authorize|]+ , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]+ } -- fix key from your application edit page -- https://stackapps.com/apps/oauth@@ -63,40 +71,59 @@ stackexchangeAppKey = "xxxxxx" stackexchangeKey :: OAuth2-stackexchangeKey = OAuth2 { oauthClientId = "xx"- , oauthClientSecret = Just "xxxxxxxxxxxxxxx"- , oauthCallback = Just [uri|http://c.haskellcn.org/cb|]- , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|]- , oauthAccessTokenEndpoint = [uri|https://stackexchange.com/oauth/access_token|]- }+stackexchangeKey = OAuth2+ { oauthClientId = "xx"+ , oauthClientSecret = Just "xxxxxxxxxxxxxxx"+ , oauthCallback = Just [uri|http://c.haskellcn.org/cb|]+ , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|]+ , oauthAccessTokenEndpoint =+ [uri|https://stackexchange.com/oauth/access_token|]+ } dropboxKey :: OAuth2-dropboxKey = OAuth2 { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]- }+dropboxKey = OAuth2+ { oauthClientId = "xxx"+ , oauthClientSecret = Just "xxx"+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+ , oauthOAuthorizeEndpoint = [uri|https://www.dropbox.com/1/oauth2/authorize|]+ , oauthAccessTokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]+ } oktaKey :: OAuth2-oktaKey = OAuth2 { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|]- , oauthAccessTokenEndpoint = [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|]- }+oktaKey = OAuth2+ { oauthClientId = "xxx"+ , oauthClientSecret = Just "xxx"+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+ , oauthOAuthorizeEndpoint =+ [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|]+ , oauthAccessTokenEndpoint =+ [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|]+ } azureADKey :: OAuth2-azureADKey = OAuth2 { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://login.windows.net/common/oauth2/authorize|]- , oauthAccessTokenEndpoint = [uri|https://login.windows.net/common/oauth2/token|]- }+azureADKey = OAuth2+ { oauthClientId = "xxx"+ , oauthClientSecret = Just "xxx"+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+ , oauthOAuthorizeEndpoint =+ [uri|https://login.windows.net/common/oauth2/authorize|]+ , oauthAccessTokenEndpoint =+ [uri|https://login.windows.net/common/oauth2/token|]+ } zohoKey :: OAuth2-zohoKey = OAuth2 { oauthClientId = "xxx"- , oauthClientSecret = Just "xxx"- , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]- , oauthOAuthorizeEndpoint = [uri|https://accounts.zoho.com/oauth/v2/auth|]- , oauthAccessTokenEndpoint = [uri|https://accounts.zoho.com/oauth/v2/token|]- }+zohoKey = OAuth2+ { oauthClientId = "xxx"+ , oauthClientSecret = Just "xxx"+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+ , oauthOAuthorizeEndpoint = [uri|https://accounts.zoho.com/oauth/v2/auth|]+ , oauthAccessTokenEndpoint = [uri|https://accounts.zoho.com/oauth/v2/token|]+ }++auth0Key :: OAuth2+auth0Key = OAuth2+ { oauthClientId = "xxx"+ , oauthClientSecret = Just "xxx"+ , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|]+ , oauthOAuthorizeEndpoint = [uri|https://foo.auth0.com/authorize|]+ , oauthAccessTokenEndpoint = [uri|https://foo.auth0.com/oauth/token|]+ }
− example/README.md
@@ -1,19 +0,0 @@--* IDPs- - AzureAD: <https://docs.microsoft.com/en-us/azure/active-directory/develop/v1-protocols-oauth-code>- - 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>--* WIP: Linkedin- - <https://developer.linkedin.com>--* NOTES- - classes in Types.hs takes a (`IDP`) as first parameter but it is actually not used. bad pattern. how to fix it??- - refactor: `App.hs` is messy!
+ example/README.org view
@@ -0,0 +1,26 @@+* IDPs++- Auth0: <https://auth0.com/docs/authorization/protocols/protocol-oauth2>+- AzureAD: <https://docs.microsoft.com/en-us/azure/active-directory/develop/v1-protocols-oauth-code>+- Douban: <http://developers.douban.com/wiki/?title=oauth2>+- DropBox: <https://www.dropbox.com/developers/reference/oauth-guide>+- Facebook: <http://developers.facebook.com/docs/facebook-login/>+- Fitbit: <http://dev.fitbit.com/docs/oauth2/>+- Github: <http://developer.github.com/v3/oauth/>+- Google: <https://developers.google.com/accounts/docs/OAuth2WebServer>+- Okta: https://developer.okta.com/docs/reference/api/oidc/+- StackExchange: <https://api.stackexchange.com/docs/authentication>+ - StackExchange Apps page: <https://stackapps.com/apps/oauth>+- Weibo: <http://open.weibo.com/wiki/Oauth2>+- ZOHO: https://www.zoho.com/crm/developer/docs/api/v2/oauth-overview.html++* WIP: Linkedin++ - <https://developer.linkedin.com>++* NOTES+- classes in Types.hs takes a (`IDP`) as first parameter but it is actually not used. bad pattern. how to fix it??+- refactor: `App.hs` is messy!+- It is tedious to add a new IDP (especially support OIDC)+ a. creates entry in ~Key.hs~+ b. creates a IDP module which mostly are boilerpate code, needs reference to OAuth2 Key object multiple times
example/Types.hs view
@@ -1,34 +1,33 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} module Types where -import Control.Concurrent.MVar-import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as BSL-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 Control.Concurrent.MVar+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.HashMap.Strict as Map+import Data.Hashable+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+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 @@ -51,32 +50,36 @@ -- Heterogenous collections -- https://wiki.haskell.org/Heterogenous_collections ---data IDPApp = forall a. (IDP a,- HasTokenRefreshReq a,- HasTokenReq a,- HasUserReq a,- HasLabel a,- HasAuthUri a) => IDPApp a+data IDPApp+ = forall a.+ ( HasTokenRefreshReq a,+ HasTokenReq a,+ HasUserReq a,+ HasLabel a,+ HasAuthUri a+ ) =>+ IDPApp a -- dummy oauth2 request error ---data Errors =- SomeRandomError+data Errors+ = SomeRandomError deriving (Show, Eq, Generic) instance FromJSON Errors where- parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+ parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} -newtype LoginUser =- LoginUser { loginUserName :: Text- } deriving (Eq, Show)+newtype LoginUser = LoginUser+ { loginUserName :: Text+ }+ deriving (Eq, Show) -data IDPData =- IDPData { codeFlowUri :: Text- , loginUser :: Maybe LoginUser- , oauth2Token :: Maybe OAuth2Token- , idpDisplayLabel :: IDPLabel- }+data IDPData = IDPData+ { codeFlowUri :: Text,+ loginUser :: Maybe LoginUser,+ oauth2Token :: Maybe OAuth2Token,+ idpDisplayLabel :: IDPLabel+ } -- simplify use case to only allow one idp instance for now. instance Eq IDPData where@@ -85,23 +88,29 @@ instance Ord IDPData where a `compare` b = idpDisplayLabel a `compare` idpDisplayLabel b -newtype TemplateData = TemplateData { idpTemplateData :: [IDPData]- } deriving (Eq)+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')- ]+ 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' ]+ toMustache t' =+ M.object+ ["name" ~> loginUserName t'] instance ToMustache TemplateData where- toMustache td' = M.object- [ "idps" ~> idpTemplateData td'- ]+ toMustache td' =+ M.object+ [ "idps" ~> idpTemplateData td'+ ]
hoauth2.cabal view
@@ -1,7 +1,7 @@ Cabal-version: 2.4 Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy-Version: 1.16.0+Version: 1.16.1 Synopsis: Haskell OAuth2 authentication client @@ -46,6 +46,7 @@ example/IDP/Fitbit.hs example/IDP/Douban.hs example/IDP/Linkedin.hs+ example/IDP/Auth0.hs example/IDP.hs example/App.hs example/Session.hs@@ -53,7 +54,7 @@ example/Utils.hs example/Views.hs example/main.hs- example/README.md+ example/README.org example/templates/index.mustache example/assets/main.css @@ -106,6 +107,7 @@ IDP.Fitbit IDP.Github IDP.Google+ IDP.Auth0 IDP.Okta IDP.StackExchange IDP.Weibo@@ -126,18 +128,15 @@ http-types >= 0.11 && < 0.13, wai >= 3.2 && < 3.3, warp >= 3.2 && < 3.4,- containers >= 0.4 && < 0.7, aeson >= 1.3.0.0 && < 1.6, microlens >= 0.4.0 && < 0.5, unordered-containers >= 0.2.5,- wai-extra >= 3.0.21.0 && < 3.2, wai-middleware-static >= 0.8.1 && < 0.10.0, mustache >= 2.2.3 && < 2.4.0,- mtl >= 2.2.1 && < 2.3, scotty >= 0.10.0 && < 0.13, binary >= 0.8.3.0 && < 0.8.9, parsec >= 3.1.11 && < 3.2.0 ,- hashable >= 1.2.6 && < 1.4.0,+ hashable >= 1.2.6 && < 1.5.0, hoauth2 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
src/Network/OAuth/OAuth2/Internal.hs view
@@ -1,89 +1,94 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK -ignore-exports #-} -- | A simple OAuth2 Haskell binding. (This is supposed to be -- independent of the http client used.)- module Network.OAuth.OAuth2.Internal where -import Control.Applicative-import Control.Arrow (second)-import Control.Monad.Catch-import Data.Aeson-import Data.Aeson.Types (Parser, explicitParseFieldMaybe)-import Data.Binary (Binary)-import qualified Data.ByteString as BS+import Control.Applicative+import Control.Arrow (second)+import Control.Monad.Catch+import Data.Aeson+import Data.Aeson.Types (Parser, explicitParseFieldMaybe)+import Data.Binary (Binary)+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL-import Data.Maybe-import Data.Semigroup ((<>))-import Data.Text (Text, pack, unpack)-import Data.Text.Encoding-import GHC.Generics-import Lens.Micro-import Lens.Micro.Extras-import Network.HTTP.Conduit as C-import qualified Network.HTTP.Types as H-import URI.ByteString-import URI.ByteString.Aeson ()+import Data.Maybe+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding+import GHC.Generics+import Lens.Micro+import Lens.Micro.Extras+import Network.HTTP.Conduit as C+import qualified Network.HTTP.Types as H+import URI.ByteString+import URI.ByteString.Aeson () --------------------------------------------------+ -- * Data Types+ -------------------------------------------------- -- | Query Parameter Representation-data OAuth2 = OAuth2 {- oauthClientId :: Text- , oauthClientSecret :: Maybe Text- , oauthOAuthorizeEndpoint :: URI- , oauthAccessTokenEndpoint :: URI- , oauthCallback :: Maybe URI- } deriving (Show, Eq)+data OAuth2 = OAuth2+ { oauthClientId :: Text,+ oauthClientSecret :: Maybe Text,+ oauthOAuthorizeEndpoint :: URI,+ oauthAccessTokenEndpoint :: URI,+ oauthCallback :: Maybe URI+ }+ deriving (Show, Eq) -newtype AccessToken = AccessToken { atoken :: Text } deriving (Binary, Eq, Show, FromJSON, ToJSON)-newtype RefreshToken = RefreshToken { rtoken :: Text } deriving (Binary, Eq, Show, FromJSON, ToJSON)-newtype IdToken = IdToken { idtoken :: Text } deriving (Binary, Eq, Show, FromJSON, ToJSON)-newtype ExchangeToken = ExchangeToken { extoken :: Text } deriving (Show, FromJSON, ToJSON)+newtype AccessToken = AccessToken {atoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) +newtype RefreshToken = RefreshToken {rtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON) +newtype IdToken = IdToken {idtoken :: Text} deriving (Binary, Eq, Show, FromJSON, ToJSON)++newtype ExchangeToken = ExchangeToken {extoken :: Text} deriving (Show, FromJSON, ToJSON)+ -- | The gained Access Token. Use @Data.Aeson.decode@ to -- decode string to @AccessToken@. The @refreshToken@ is -- special in some cases, -- e.g. <https://developers.google.com/accounts/docs/OAuth2>-data OAuth2Token = OAuth2Token {- accessToken :: AccessToken- , refreshToken :: Maybe RefreshToken- , expiresIn :: Maybe Int- , tokenType :: Maybe Text- , idToken :: Maybe IdToken- } deriving (Eq, Show, Generic)+data OAuth2Token = OAuth2Token+ { accessToken :: AccessToken,+ refreshToken :: Maybe RefreshToken,+ expiresIn :: Maybe Int,+ tokenType :: Maybe Text,+ idToken :: Maybe IdToken+ }+ deriving (Eq, Show, Generic) instance Binary OAuth2Token parseIntFlexible :: Value -> Parser Int parseIntFlexible (String s) = pure . read $ unpack s-parseIntFlexible v = parseJSON v+parseIntFlexible v = parseJSON v -- | Parse JSON data into 'OAuth2Token' instance FromJSON OAuth2Token where- parseJSON = withObject "OAuth2Token" $ \v -> OAuth2Token- <$> v .: "access_token"- <*> v .:? "refresh_token"- <*> explicitParseFieldMaybe parseIntFlexible v "expires_in"- <*> v .:? "token_type"- <*> v .:? "id_token"+ parseJSON = withObject "OAuth2Token" $ \v ->+ OAuth2Token+ <$> v .: "access_token"+ <*> v .:? "refresh_token"+ <*> explicitParseFieldMaybe parseIntFlexible v "expires_in"+ <*> v .:? "token_type"+ <*> v .:? "id_token"+ instance ToJSON OAuth2Token where- toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }- toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' }+ toJSON = genericToJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}+ toEncoding = genericToEncoding defaultOptions {fieldLabelModifier = camelTo2 '_'} -data OAuth2Error a =- OAuth2Error- { error :: Either Text a- , errorDescription :: Maybe Text- , errorUri :: Maybe (URIRef Absolute) }+data OAuth2Error a = OAuth2Error+ { error :: Either Text a,+ errorDescription :: Maybe Text,+ errorUri :: Maybe (URIRef Absolute)+ } deriving (Show, Eq, Generic) instance FromJSON err => FromJSON (OAuth2Error err) where@@ -96,8 +101,8 @@ parseJSON _ = fail "Expected an object" instance ToJSON err => ToJSON (OAuth2Error err) where- toJSON = genericToJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }- toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }+ toJSON = genericToJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}+ toEncoding = genericToEncoding defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True} parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err parseOAuth2Error string =@@ -111,7 +116,9 @@ Nothing --------------------------------------------------+ -- * Types Synonym+ -------------------------------------------------- -- | Is either 'Left' containing an error or 'Right' containg a result@@ -123,51 +130,76 @@ type QueryParams = [(BS.ByteString, BS.ByteString)] --------------------------------------------------+ -- * URLs+ -------------------------------------------------- -- | Prepare the authorization URL. Redirect to this URL -- asking for user interactive authentication. authorizationUrl :: OAuth2 -> URI authorizationUrl oa = over (queryL . queryPairsL) (++ queryParts) (oauthOAuthorizeEndpoint oa)- where queryParts = catMaybes [ Just ("client_id", encodeUtf8 $ oauthClientId oa)- , Just ("response_type", "code")- , fmap (("redirect_uri",) . serializeURIRef') (oauthCallback oa) ]+ where+ queryParts =+ catMaybes+ [ Just ("client_id", encodeUtf8 $ oauthClientId oa),+ Just ("response_type", "code"),+ fmap (("redirect_uri",) . serializeURIRef') (oauthCallback oa)+ ] -- | Prepare the URL and the request body query for fetching an access token.-accessTokenUrl :: OAuth2- -> ExchangeToken -- ^ access code gained via authorization URL- -> (URI, PostBody) -- ^ access token request URL plus the request body.+accessTokenUrl ::+ OAuth2 ->+ -- | access code gained via authorization URL+ ExchangeToken ->+ -- | access token request URL plus the request body.+ (URI, PostBody) accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code") -- | Prepare the URL and the request body query for fetching an access token, with -- optional grant type.-accessTokenUrl' :: OAuth2- -> ExchangeToken -- ^ access code gained via authorization URL- -> Maybe Text -- ^ Grant Type- -> (URI, PostBody) -- ^ access token request URL plus the request body.+accessTokenUrl' ::+ OAuth2 ->+ -- | access code gained via authorization URL+ ExchangeToken ->+ -- | Grant Type+ Maybe Text ->+ -- | access token request URL plus the request body.+ (URI, PostBody) accessTokenUrl' oa code gt = (uri, body)- where uri = oauthAccessTokenEndpoint oa- body = catMaybes [ Just ("code", encodeUtf8 $ extoken code)- , ("redirect_uri",) . serializeURIRef' <$> oauthCallback oa- , fmap (("grant_type",) . encodeUtf8) gt- ]+ where+ uri = oauthAccessTokenEndpoint oa+ body =+ catMaybes+ [ Just ("code", encodeUtf8 $ extoken code),+ ("redirect_uri",) . serializeURIRef' <$> oauthCallback oa,+ fmap (("grant_type",) . encodeUtf8) gt+ ] -- | Using a Refresh Token. Obtain a new access token by -- sending a refresh token to the Authorization server.-refreshAccessTokenUrl :: OAuth2- -> RefreshToken -- ^ refresh token gained via authorization URL- -> (URI, PostBody) -- ^ refresh token request URL plus the request body.+refreshAccessTokenUrl ::+ OAuth2 ->+ -- | refresh token gained via authorization URL+ RefreshToken ->+ -- | refresh token request URL plus the request body.+ (URI, PostBody) refreshAccessTokenUrl oa token = (uri, body)- where uri = oauthAccessTokenEndpoint oa- body = [ ("grant_type", "refresh_token")- , ("refresh_token", encodeUtf8 $ rtoken token)- ]+ where+ uri = oauthAccessTokenEndpoint oa+ body =+ [ ("grant_type", "refresh_token"),+ ("refresh_token", encodeUtf8 $ rtoken token)+ ] -- | For `GET` method API.-appendAccessToken :: URIRef a -- ^ Base URI- -> AccessToken -- ^ Authorized Access Token- -> URIRef a -- ^ Combined Result+appendAccessToken ::+ -- | Base URI+ URIRef a ->+ -- | Authorized Access Token+ AccessToken ->+ -- | Combined Result+ URIRef a appendAccessToken uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri -- | Create 'QueryParams' with given access token value.@@ -176,7 +208,7 @@ appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a appendQueryParams params =- over (queryL . queryPairsL) (params ++ )+ over (queryL . queryPairsL) (params ++) uriToRequest :: MonadThrow m => URI -> m Request uriToRequest uri = do@@ -184,35 +216,39 @@ "http" -> return False "https" -> return True s -> throwM $ InvalidUrlException (show uri) ("Invalid scheme: " ++ show s)- let- query = fmap (second Just) (view (queryL . queryPairsL) uri)- hostL = authorityL . _Just . authorityHostL . hostBSL- portL = authorityL . _Just . authorityPortL . _Just . portNumberL- defaultPort = (if ssl then 443 else 80) :: Int+ let query = fmap (second Just) (view (queryL . queryPairsL) uri)+ hostL = authorityL . _Just . authorityHostL . hostBSL+ portL = authorityL . _Just . authorityPortL . _Just . portNumberL+ defaultPort = (if ssl then 443 else 80) :: Int - req = setQueryString query $ defaultRequest {- secure = ssl,- path = view pathL uri- }- req2 = (over hostLens . maybe id const . preview hostL) uri req- req3 = (over portLens . (const . fromMaybe defaultPort). preview portL) uri req2+ req =+ setQueryString query $+ defaultRequest+ { secure = ssl,+ path = view pathL uri+ }+ req2 = (over hostLens . maybe id const . preview hostL) uri req+ req3 = (over portLens . (const . fromMaybe defaultPort) . preview portL) uri req2 return req3 requestToUri :: Request -> URI requestToUri req = URI- (Scheme (if secure req- then "https"- else "http"))+ ( Scheme+ ( if secure req+ then "https"+ else "http"+ )+ ) (Just (Authority Nothing (Host $ host req) (Just $ Port $ port req))) (path req) (Query $ H.parseSimpleQuery $ queryString req) Nothing hostLens :: Lens' Request BS.ByteString-hostLens f req = f (C.host req) <&> \h' -> req { C.host = h' }+hostLens f req = f (C.host req) <&> \h' -> req {C.host = h'} {-# INLINE hostLens #-} portLens :: Lens' Request Int-portLens f req = f (C.port req) <&> \p' -> req { C.port = p' }+portLens f req = f (C.port req) <&> \p' -> req {C.port = p'} {-# INLINE portLens #-}