hoauth2 1.10.1 → 1.10.2

raw patch · 19 files changed

+201/−29 lines, 19 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• example/App.hs +68/−20
• example/IDP.hs +3/−1
• example/IDP/AzureAD.hs +3/−0
• example/IDP/Douban.hs +3/−0
• example/IDP/Dropbox.hs +3/−0
• example/IDP/Facebook.hs +3/−0
• example/IDP/Fitbit.hs +3/−0
• example/IDP/Github.hs +3/−0
• example/IDP/Google.hs +3/−0
• example/IDP/Okta.hs +5/−2
• example/IDP/StackExchange.hs +3/−0
• example/IDP/Weibo.hs +3/−0
• example/IDP/ZOHO.hs +69/−0
• example/Keys.hs.sample +8/−0
• example/README.md +4/−0
• example/Types.hs +10/−1
• example/templates/index.mustache +1/−0
• hoauth2.cabal +2/−1
• src/Network/OAuth/OAuth2/Internal.hs +4/−4

@@ -9,7 +9,7 @@  import           Control.Monad import           Control.Monad.Error.Class-import           Control.Monad.IO.Class        (liftIO)+import           Control.Monad.IO.Class        (MonadIO, liftIO) import           Data.Bifunctor import           Data.Maybe import           Data.Text.Lazy                (Text)@@ -52,6 +52,7 @@     get "/" $ indexH cache     get "/oauth2/callback" $ callbackH cache     get "/logout" $ logoutH cache+    get "/refresh" $ refreshH cache  debug :: Bool debug = True@@ -69,13 +70,45 @@ globalErrorHandler :: Text -> ActionM () globalErrorHandler t = status status401 >> html t -logoutH :: CacheStore -> ActionM ()-logoutH c = do+readIdpParam :: ActionM (Either Text IDPApp)+readIdpParam = do   pas <- params   let idpP = paramValue "idp" pas   when (null idpP) redirectToHomeM-  let eitherIdpApp = parseIDP (head idpP)+  return $ parseIDP (head idpP)++refreshH :: CacheStore -> ActionM ()+refreshH c = do+  eitherIdpApp <- readIdpParam   case eitherIdpApp of+    Right (IDPApp idp) -> do+      maybeIdpData <- lookIdp c idp+      when (isNothing maybeIdpData) (errorM "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         -> errorM (TL.pack e)+    Left e       -> errorM ("logout: unknown IDP " `TL.append` e)++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)++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       -> errorM ("logout: unknown IDP " `TL.append` e) @@ -106,28 +139,43 @@   when (isNothing maybeIdpData) (errorM "fetchTokenAndUser: cannot find idp data from cache")    let idpData = fromJust maybeIdpData-  result <- liftIO $ tryFetchUser idp code-+  result <- liftIO $ fetchTokenAndUser' c code idp idpData   case result of-    Right luser -> updateIdp c idpData luser >> redirectToHomeM-    Left err    -> errorM ("fetchTokenAndUser: " `TL.append` err)--  where lookIdp c1 idp1 = liftIO $ lookupKey c1 (idpLabel idp1)-        updateIdp c1 oldIdpData luser = liftIO $ insertIDPData c1 (oldIdpData {loginUser = Just luser })+    Right _  -> redirectToHomeM+    Left err -> errorM err --- TODO: may use Exception monad to capture error in this IO monad----tryFetchUser :: (HasTokenReq a, HasUserReq a, HasLabel a)-  => a-  -> TL.Text           -- ^ code-  -> IO (Either Text LoginUser)-tryFetchUser idp code = do+fetchTokenAndUser' :: (HasTokenReq a, HasUserReq a) =>+                      CacheStore -> Text -> a -> IDPData -> IO (Either Text ())+fetchTokenAndUser' c code idp idpData = do   mgr <- newManager tlsManagerSettings   token <- tokenReq idp mgr (ExchangeToken $ TL.toStrict code)   when debug (print token)-  case token of-    Right at -> fetchUser idp mgr (accessToken at)++  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)++  case result of+    Right (luser, at) -> updateIdp c idpData luser at >> return (Right ())+    Left err    -> return $ Left ("fetchTokenAndUser: " `TL.append` err)++  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 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 mgr at idp = do+  re <- fetchUser idp mgr (accessToken at)+  return $ case re of+    Right user' -> Right (user', at)+    Left e      -> Left e  -- * Fetch UserInfo --

@@ -14,6 +14,7 @@ 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 @@ -30,6 +31,7 @@        , IDPApp IOkta.Okta        , IDPApp IStackExchange.StackExchange        , IDPApp IWeibo.Weibo+       , IDPApp IZOHO.ZOHO        ]  initIdps :: CacheStore -> IO ()@@ -42,4 +44,4 @@ parseIDP s = maybe (Left s) Right (Map.lookup s idpsMap)  mkIDPData :: IDPApp -> IDPData-mkIDPData (IDPApp idp) = IDPData (authUri idp) Nothing (idpLabel idp)+mkIDPData (IDPApp idp) = IDPData (authUri idp) Nothing Nothing (idpLabel idp)

@@ -23,6 +23,9 @@  instance HasLabel AzureAD +instance HasTokenRefreshReq AzureAD where+  tokenRefreshReq _ mgr = refreshAccessToken mgr azureADKey+ instance HasTokenReq AzureAD where   tokenReq _ mgr = fetchAccessToken mgr azureADKey 

@@ -23,6 +23,9 @@  instance HasLabel Douban +instance HasTokenRefreshReq Douban where+  tokenRefreshReq _ mgr = refreshAccessToken mgr doubanKey+ instance HasTokenReq Douban where   tokenReq _ mgr = fetchAccessToken2 mgr doubanKey 

@@ -27,6 +27,9 @@ instance HasTokenReq Dropbox where   tokenReq _ mgr = fetchAccessToken mgr dropboxKey +instance HasTokenRefreshReq Dropbox where+  tokenRefreshReq _ mgr = refreshAccessToken mgr dropboxKey+ instance HasUserReq Dropbox where   userReq _ mgr at = do     re <- authPostBS3 mgr at userInfoUri

@@ -26,6 +26,9 @@ instance HasTokenReq Facebook where   tokenReq _ mgr = fetchAccessToken2 mgr facebookKey +instance HasTokenRefreshReq Facebook where+  tokenRefreshReq _ mgr = refreshAccessToken mgr facebookKey+ instance HasUserReq Facebook where   userReq _ mgr at = do     re <- authGetJSON mgr at userInfoUri

@@ -28,6 +28,9 @@ instance HasTokenReq Fitbit where   tokenReq _ mgr = fetchAccessToken mgr fitbitKey +instance HasTokenRefreshReq Fitbit where+  tokenRefreshReq _ mgr = refreshAccessToken mgr fitbitKey+ instance HasUserReq Fitbit where   userReq _ mgr at = do     re <- authGetJSON mgr at userInfoUri

@@ -26,6 +26,9 @@ instance HasTokenReq Github where   tokenReq _ mgr = fetchAccessToken mgr githubKey +instance HasTokenRefreshReq Github where+  tokenRefreshReq _ mgr = refreshAccessToken mgr githubKey+ instance HasUserReq Github where   userReq _ mgr at = do     re <- authGetJSON mgr at userInfoUri

@@ -26,6 +26,9 @@ instance HasTokenReq Google where   tokenReq _ mgr = fetchAccessToken mgr googleKey +instance HasTokenRefreshReq Google where+  tokenRefreshReq _ mgr = refreshAccessToken mgr googleKey+ instance HasUserReq Google where   userReq _ mgr at = do     re <- authGetJSON mgr at userInfoUri

@@ -26,6 +26,9 @@ instance HasTokenReq Okta where   tokenReq _ mgr = fetchAccessToken mgr oktaKey +instance HasTokenRefreshReq Okta where+  tokenRefreshReq _ mgr = refreshAccessToken mgr oktaKey+ instance HasUserReq Okta where   userReq _ mgr at = do     re <- authGetJSON mgr at userInfoUri@@ -33,8 +36,8 @@  instance HasAuthUri Okta where   authUri _ = createCodeUri oktaKey [ ("state", "Okta.test-state-123")-                                        , ("scope", "openid profile")-                                        ]+                                    , ("scope", "openid profile offline_access")+                                    ]  data OktaUser = OktaUser { name              :: Text                          , preferredUsername :: Text

@@ -34,6 +34,9 @@ instance HasTokenReq StackExchange where   tokenReq _ mgr = fetchAccessToken2 mgr stackexchangeKey +instance HasTokenRefreshReq StackExchange where+  tokenRefreshReq _ mgr = refreshAccessToken mgr stackexchangeKey+ instance HasUserReq StackExchange where   userReq _ mgr token = do     re <- authGetBS2 mgr token

@@ -25,6 +25,9 @@  instance HasLabel Weibo +instance HasTokenRefreshReq Weibo where+  tokenRefreshReq _ mgr = refreshAccessToken mgr weiboKey+ instance HasTokenReq Weibo where   tokenReq _ mgr = fetchAccessToken mgr weiboKey 

@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module IDP.ZOHO 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 ZOHO = ZOHO deriving (Show, Generic)++instance Hashable ZOHO++instance IDP ZOHO++instance HasLabel ZOHO++instance HasTokenReq ZOHO where+  tokenReq _ mgr = fetchAccessToken2 mgr zohoKey++instance HasTokenRefreshReq ZOHO where+  tokenRefreshReq _ mgr = refreshAccessToken2 mgr zohoKey++instance HasUserReq ZOHO where+  userReq _ mgr at = do+    re <- authGetJSON mgr at userInfoUri+    return (second toLoginUser re)++instance HasAuthUri ZOHO where+  authUri _ = createCodeUri zohoKey [ ("state", "ZOHO.test-state-123")+                                    , ("scope", "ZohoCRM.users.READ")+                                    , ("access_type", "offline")+                                    , ("prompt", "consent")+                                    ]++data ZOHOUser = ZOHOUser { email    :: Text+                         , fullName :: Text+                         } deriving (Show, Generic)++newtype ZOHOUserResp = ZOHOUserResp { users :: [ZOHOUser] }+  deriving (Show, Generic)++instance FromJSON ZOHOUserResp where+    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++instance FromJSON ZOHOUser where+    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }++userInfoUri :: URI+userInfoUri = [uri|https://www.zohoapis.com/crm/v2/users|]+  -- `oauth/user/info` url does not work and find answer from+  -- https://help.zoho.com/portal/community/topic/oauth2-api-better-document-oauth-user-info++toLoginUser :: ZOHOUserResp -> LoginUser+toLoginUser resp =+  let us = users resp+  in+    case us of+      []    -> LoginUser { loginUserName = "no user found" }+      (a:_) -> LoginUser { loginUserName = fullName a }+

@@ -92,3 +92,11 @@                     , 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 = "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|]+                    }

@@ -13,3 +13,7 @@  * 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!

@@ -42,13 +42,21 @@ class (IDP a) => HasTokenReq a where   tokenReq :: a -> Manager -> ExchangeToken -> IO (OAuth2Result TR.Errors OAuth2Token) +class (IDP a) => HasTokenRefreshReq a where+  tokenRefreshReq :: a -> Manager -> RefreshToken -> IO (OAuth2Result TR.Errors OAuth2Token)+ class (IDP a) => HasUserReq a where   userReq :: a -> Manager -> AccessToken -> IO (Either BSL.ByteString LoginUser)  -- Heterogenous collections -- https://wiki.haskell.org/Heterogenous_collections ---data IDPApp = forall a. (IDP a, HasTokenReq a, HasUserReq a, HasLabel a, HasAuthUri a) => IDPApp a+data IDPApp = forall a. (IDP a,+                         HasTokenRefreshReq a,+                         HasTokenReq a,+                         HasUserReq a,+                         HasLabel a,+                         HasAuthUri a) => IDPApp a  -- dummy oauth2 request error --@@ -66,6 +74,7 @@ data IDPData =   IDPData { codeFlowUri     :: Text           , loginUser       :: Maybe LoginUser+          , oauth2Token     :: Maybe OAuth2Token           , idpDisplayLabel :: IDPLabel           } 

@@ -17,6 +17,7 @@             <div class="result">Hello, {{name}}</div>             {{/user}}             <a href="/logout?idp={{name}}">Logout</a>+            <a href="/refresh?idp={{name}}">Refresh</a>             {{/isLogin}}          </section>

@@ -1,7 +1,7 @@ Cabal-version: 2.4 Name:                hoauth2 -- http://wiki.haskell.org/Package_versioning_policy-Version:             1.10.1+Version:             1.10.2  Synopsis:            Haskell OAuth2 authentication client @@ -110,6 +110,7 @@                        IDP.StackExchange                        IDP.Weibo                        IDP.Linkedin+                       IDP.ZOHO                        Keys                        Session                        Types

@@ -43,9 +43,9 @@     , oauthCallback            :: Maybe URI     } deriving (Show, Eq) -newtype AccessToken = AccessToken { atoken :: Text } deriving (Binary, Show, FromJSON, ToJSON)-newtype RefreshToken = RefreshToken { rtoken :: Text } deriving (Binary, Show, FromJSON, ToJSON)-newtype IdToken = IdToken { idtoken :: Text } deriving (Binary, 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)  @@ -59,7 +59,7 @@     , expiresIn    :: Maybe Int     , tokenType    :: Maybe Text     , idToken      :: Maybe IdToken-    } deriving (Show, Generic)+    } deriving (Eq, Show, Generic)  instance Binary OAuth2Token