diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ## Nix diff --git a/example/App.hs b/example/App.hs --- a/example/App.hs +++ b/example/App.hs @@ -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) diff --git a/example/IDP.hs b/example/IDP.hs --- a/example/IDP.hs +++ b/example/IDP.hs @@ -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) diff --git a/example/IDP/Auth0.hs b/example/IDP/Auth0.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Auth0.hs @@ -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} diff --git a/example/IDP/Okta.hs b/example/IDP/Okta.hs --- a/example/IDP/Okta.hs +++ b/example/IDP/Okta.hs @@ -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 } diff --git a/example/IDP/Weibo.hs b/example/IDP/Weibo.hs --- a/example/IDP/Weibo.hs +++ b/example/IDP/Weibo.hs @@ -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} diff --git a/example/Keys.hs b/example/Keys.hs --- a/example/Keys.hs +++ b/example/Keys.hs @@ -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|] + } diff --git a/example/Keys.hs.sample b/example/Keys.hs.sample --- a/example/Keys.hs.sample +++ b/example/Keys.hs.sample @@ -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|] + } diff --git a/example/README.md b/example/README.md deleted file mode 100644 --- a/example/README.md +++ /dev/null @@ -1,19 +0,0 @@ - -* IDPs - - AzureAD: - - douban: - - Google: - - Github: - - Facebook: - - Fitbit: - - StackExchange: - - StackExchange Apps page: - - DropBox: - - Weibo: - -* WIP: Linkedin - - - -* 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! diff --git a/example/README.org b/example/README.org new file mode 100644 --- /dev/null +++ b/example/README.org @@ -0,0 +1,26 @@ +* IDPs + +- Auth0: +- AzureAD: +- Douban: +- DropBox: +- Facebook: +- Fitbit: +- Github: +- Google: +- Okta: https://developer.okta.com/docs/reference/api/oidc/ +- StackExchange: + - StackExchange Apps page: +- Weibo: +- ZOHO: https://www.zoho.com/crm/developer/docs/api/v2/oauth-overview.html + +* WIP: Linkedin + + - + +* 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 diff --git a/example/Types.hs b/example/Types.hs --- a/example/Types.hs +++ b/example/Types.hs @@ -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' + ] diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -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 diff --git a/src/Network/OAuth/OAuth2/Internal.hs b/src/Network/OAuth/OAuth2/Internal.hs --- a/src/Network/OAuth/OAuth2/Internal.hs +++ b/src/Network/OAuth/OAuth2/Internal.hs @@ -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. -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 #-}