hoauth2 2.1.0 → 2.2.0

raw patch · 31 files changed

+83/−1866 lines, 31 filesdep +transformersdep −hoauth2dep −mustachedep −parsecdep ~basedep ~binarydep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependencies removed: hoauth2, mustache, parsec, scotty, wai, wai-middleware-static, warp

Dependency ranges changed: base, binary, unordered-containers, uri-bytestring

API changes (from Hackage documentation)

Files

• README.md +0/−27
• README.org +3/−0
• example/App.hs +0/−206
• example/IDP.hs +0/−50
• example/IDP/Auth0.hs +0/−63
• example/IDP/AzureAD.hs +0/−52
• example/IDP/Douban.hs +0/−53
• example/IDP/Dropbox.hs +0/−60
• example/IDP/Facebook.hs +0/−54
• example/IDP/Fitbit.hs +0/−63
• example/IDP/Github.hs +0/−51
• example/IDP/Google.hs +0/−54
• example/IDP/Linkedin.hs +0/−46
• example/IDP/Okta.hs +0/−71
• example/IDP/Slack.hs +0/−63
• example/IDP/StackExchange.hs +0/−77
• example/IDP/Weibo.hs +0/−71
• example/IDP/ZOHO.hs +0/−69
• example/Keys.hs +0/−141
• example/Keys.hs.sample +0/−141
• example/README.org +0/−29
• example/Session.hs +0/−38
• example/Types.hs +0/−116
• example/Utils.hs +0/−37
• example/Views.hs +0/−39
• example/assets/main.css +0/−11
• example/main.hs +0/−6
• example/templates/index.mustache +0/−32
• hoauth2.cabal +9/−84
• src/Network/OAuth/OAuth2/HttpClient.hs +70/−54
• src/Network/OAuth/OAuth2/Internal.hs +1/−8

@@ -1,27 +0,0 @@-[![Build](https://github.com/freizl/hoauth2/actions/workflows/build.yml/badge.svg)](https://github.com/freizl/hoauth2/actions/workflows/build.yml)-[![lint](https://github.com/freizl/hoauth2/actions/workflows/lint.yml/badge.svg)](https://github.com/freizl/hoauth2/actions/workflows/lint.yml)-[![Travis Status](https://secure.travis-ci.org/freizl/hoauth2.svg?branch=master)](http://travis-ci.org/freizl/hoauth2)-[![Hackage](https://img.shields.io/hackage/v/hoauth2.svg)](https://hackage.haskell.org/package/hoauth2)--# Introduction--A lightweight OAuth2 Haskell binding.--# 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 start-demo`-- open <http://localhost:9988>--## Nix--- assume `cabal-install` has been install (either globally or in nix store)-- `nix-shell` then could do `cabal v2-` build-- or `nix-build`--# Contribute--Feel free send pull request or submit issue ticket.

@@ -0,0 +1,3 @@+* Introduction++A mixed Haskell binding of [OAuth2 spec](https://datatracker.ietf.org/doc/html/rfc6749) and a little bit [OIDC spec](https://openid.net/specs/openid-connect-core-1_0.html).

@@ -1,206 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE OverloadedStrings         #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TypeFamilies              #-}--module App-  ( app-  , waiApp-  ) where--import           Control.Monad-import           Control.Monad.IO.Class         ( MonadIO-                                                , liftIO-                                                )-import           Data.Bifunctor-import           Data.Maybe-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.Middleware.Static-import           Prelude-import           Session-import           Types-import           Utils-import           Views-import           Web.Scotty----------------------------------- App---------------------------------myServerPort :: Int-myServerPort = 9988--app :: IO ()-app =-  putStrLn ("Starting Server. http://localhost:" ++ show myServerPort)-    >>  waiApp-    >>= run myServerPort---- TODO: how to add either Monad or a middleware to do session?-waiApp :: IO WAI.Application-waiApp = do-  cache <- initCacheStore-  initIdps cache-  scottyApp $ do-    middleware $ staticPolicy (addBase "example/assets")-    defaultHandler globalErrorHandler-    get "/" $ indexH cache-    get "/oauth2/callback" $ callbackH cache-    get "/logout" $ logoutH cache-    get "/refresh" $ refreshH cache--debug :: Bool-debug = True------------------------------------------------------- * Handlers-----------------------------------------------------redirectToHomeM :: ActionM ()-redirectToHomeM = redirect "/"--globalErrorHandler :: Text -> ActionM ()-globalErrorHandler t = status status401 >> html t--readIdpParam :: ActionM (Either Text IDPApp)-readIdpParam = do-  pas <- params-  let idpP = paramValue "idp" pas-  when (null idpP) redirectToHomeM-  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)-           (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)--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 -> raise ("logout: unknown IDP " `TL.append` e)--indexH :: CacheStore -> ActionM ()-indexH c = liftIO (allValues c) >>= overviewTpl--callbackH :: CacheStore -> ActionM ()-callbackH c = do-  pas <- params-  let codeP  = paramValue "code" pas-  let stateP = paramValue "state" pas-  when (null codeP)  (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)--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")--  let idpData = fromJust maybeIdpData-  result <- liftIO $ fetchTokenAndUser' c code idp idpData-  case result of-    Right _   -> redirectToHomeM-    Left  err -> raise err--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)--  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 - no user found: " `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----fetchUser-  :: (HasUserReq a) => a -> Manager -> AccessToken -> IO (Either Text LoginUser)-fetchUser idp mgr token = do-  re <- userReq idp mgr token-  return (first bslToText re)

@@ -1,50 +0,0 @@-module IDP where--import qualified Data.HashMap.Strict as Map-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.Slack as ISlack-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 IAuth0.Auth0,-    IDPApp ISlack.Slack,-    IDPApp IZOHO.ZOHO-  ]--initIdps :: CacheStore -> IO ()-initIdps c = mapM_ (insertIDPData c) (fmap mkIDPData idps)--idpsMap :: Map.HashMap Text IDPApp-idpsMap = Map.fromList $ fmap (\x@(IDPApp idp) -> (idpLabel idp, x)) idps--parseIDP :: Text -> Either Text IDPApp-parseIDP s = maybe (Left s) Right (Map.lookup s idpsMap)--mkIDPData :: IDPApp -> IDPData-mkIDPData (IDPApp idp) = IDPData (authUri idp) Nothing Nothing (idpLabel idp)

@@ -1,63 +0,0 @@-{-# 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, Eq)--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}

@@ -1,52 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module IDP.AzureAD 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 AzureAD = AzureAD deriving (Show, Generic, Eq)--instance Hashable AzureAD--instance IDP AzureAD--instance HasLabel AzureAD--instance HasTokenRefreshReq AzureAD where-  tokenRefreshReq _ mgr = refreshAccessToken mgr azureADKey--instance HasTokenReq AzureAD where-  tokenReq _ mgr = fetchAccessToken mgr azureADKey--instance HasUserReq AzureAD where-  userReq _ mgr at = do-    re <- authGetJSON mgr at userInfoUri-    return (second toLoginUser re)--instance HasAuthUri AzureAD where-  authUri _ = createCodeUri azureADKey [ ("state", "AzureAD.test-state-123")-                                       , ("scope", "openid,profile")-                                       , ("resource", "https://graph.microsoft.com")-                                       ]--newtype AzureADUser = AzureADUser { mail :: Text } deriving (Show, Generic)--instance FromJSON AzureADUser where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://graph.microsoft.com/v1.0/me|]--toLoginUser :: AzureADUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = mail ouser }

@@ -1,53 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module IDP.Douban 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 Douban = Douban deriving (Show, Generic, Eq)--instance Hashable Douban--instance IDP Douban--instance HasLabel Douban--instance HasTokenRefreshReq Douban where-  tokenRefreshReq _ mgr = refreshAccessToken mgr doubanKey--instance HasTokenReq Douban where-  tokenReq _ mgr = fetchAccessToken2 mgr doubanKey--instance HasUserReq Douban where-  userReq _ mgr at = do-    re <- authGetJSON mgr at userInfoUri-    return (second toLoginUser re)--instance HasAuthUri Douban where-  authUri _ = createCodeUri doubanKey [ ("state", "Douban.test-state-123")-                                        ]--data DoubanUser = DoubanUser { name :: Text-                             , uid  :: Text-                             } deriving (Show, Generic)--instance FromJSON DoubanUser where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://api.douban.com/v2/user/~me|]--toLoginUser :: DoubanUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = name ouser }-

@@ -1,60 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module IDP.Dropbox where-import           Data.Aeson-import           Data.Bifunctor-import qualified Data.ByteString.Lazy.Char8 as BSL-import           Data.Hashable-import           Data.Text.Lazy             (Text)-import           GHC.Generics-import           Keys-import           Network.OAuth.OAuth2-import           Types-import           URI.ByteString-import           URI.ByteString.QQ-import           Utils--data Dropbox = Dropbox deriving (Show, Generic, Eq)--instance Hashable Dropbox--instance IDP Dropbox--instance HasLabel Dropbox--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-    return (re >>= (bimap BSL.pack toLoginUser . eitherDecode))---instance HasAuthUri Dropbox where-  authUri _ = createCodeUri dropboxKey [ ("state", "Dropbox.test-state-123")-                                        ]--newtype DropboxName = DropboxName { displayName :: Text }-                 deriving (Show, Generic)--data DropboxUser = DropboxUser { email :: Text-                               , name  :: DropboxName-                               } deriving (Show, Generic)--instance FromJSON DropboxName where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--instance FromJSON DropboxUser where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://api.dropboxapi.com/2/users/get_current_account|]--toLoginUser :: DropboxUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = displayName $ name ouser }

@@ -1,54 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module IDP.Facebook 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 Facebook = Facebook deriving (Show, Generic, Eq)--instance Hashable Facebook--instance IDP Facebook--instance HasLabel Facebook--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-    return (second toLoginUser re)--instance HasAuthUri Facebook where-  authUri _ = createCodeUri facebookKey [ ("state", "Facebook.test-state-123")-                                        , ("scope", "user_about_me,email")-                                        ]--data FacebookUser = FacebookUser { id    :: Text-                                 , name  :: Text-                                 , email :: Text-                                 } deriving (Show, Generic)--instance FromJSON FacebookUser where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://graph.facebook.com/me?fields=id,name,email|]--toLoginUser :: FacebookUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = name ouser }

@@ -1,63 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module IDP.Fitbit where-import           Control.Monad        (mzero)-import           Data.Aeson-import           Data.Bifunctor-import           Data.Hashable-import           Data.Text.Lazy       (Text)-import           GHC.Generics-import           Keys-import           Network.OAuth.OAuth2-import           Types-import           URI.ByteString-import           URI.ByteString.QQ-import           Utils---data Fitbit = Fitbit deriving (Show, Generic, Eq)--instance Hashable Fitbit--instance IDP Fitbit--instance HasLabel Fitbit--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-    return (second toLoginUser re)--instance HasAuthUri Fitbit where-  authUri _ = createCodeUri fitbitKey [ ("state", "Fitbit.test-state-123")-                                        , ("scope", "profile")-                                        ]--data FitbitUser = FitbitUser-    { userId   :: Text-    , userName :: Text-    , userAge  :: Int-    } deriving (Show, Eq)--instance FromJSON FitbitUser where-    parseJSON (Object o) =-        FitbitUser-        <$> ((o .: "user") >>= (.: "encodedId"))-        <*> ((o .: "user") >>= (.: "fullName"))-        <*> ((o .: "user") >>= (.: "age"))-    parseJSON _ = mzero---userInfoUri :: URI-userInfoUri = [uri|https://api.fitbit.com/1/user/-/profile.json|]--toLoginUser :: FitbitUser -> LoginUser-toLoginUser ouser = LoginUser { loginUserName = userName ouser }

@@ -1,51 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module IDP.Github 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 Github = Github deriving (Show, Generic, Eq)--instance Hashable Github--instance IDP Github--instance HasLabel Github--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-    return (second toLoginUser re)--instance HasAuthUri Github where-  authUri _ = createCodeUri githubKey [("state", "Github.test-state-123")]--data GithubUser = GithubUser { name :: Text-                             , id   :: Integer-                             } deriving (Show, Generic)--instance FromJSON GithubUser where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://api.github.com/user|]--toLoginUser :: GithubUser -> LoginUser-toLoginUser guser = LoginUser { loginUserName = name guser }

@@ -1,54 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module IDP.Google 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 Google = Google deriving (Show, Generic, Eq)--instance Hashable Google--instance IDP Google--instance HasLabel Google--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-    return (second toLoginUser re)--instance HasAuthUri Google where-  authUri _ = createCodeUri googleKey [ ("state", "Google.test-state-123")-                                      , ("scope", "https://www.googleapis.com/auth/userinfo.email")-                                        ]--data GoogleUser = GoogleUser { name :: Text-                             , id   :: Text-                             } deriving (Show, Generic)--instance FromJSON GoogleUser where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://www.googleapis.com/oauth2/v2/userinfo|]--toLoginUser :: GoogleUser -> LoginUser-toLoginUser guser = LoginUser { loginUserName = name guser }-

@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-}--{--  disabled since it's not yet working. error:-  - serviceErrorCode:100-  - message:Not enough permissions to access /me GET--}-module IDP.Linkedin where-import           Data.Aeson-import           Data.Text.Lazy    (Text)-import qualified Data.Text.Lazy    as TL-import           GHC.Generics-import           Types-import           URI.ByteString-import           URI.ByteString.QQ--data LinkedinUser = LinkedinUser { firstName :: Text-                                 , lastName  :: Text-                                 } deriving (Show, Generic, Eq)--instance FromJSON LinkedinUser where-    parseJSON = genericParseJSON defaultOptions--userInfoUri :: URI-userInfoUri = [uri|https://api.linkedin.com/v2/me|]---toLoginUser :: LinkedinUser -> LoginUser-toLoginUser LinkedinUser {..} = LoginUser { loginUserName = firstName `TL.append` " " `TL.append` lastName }--{--mkIDPData Linkedin =-  let userUri = createCodeUri linkedinKey [("state", "linkedin.test-state-123")]-  in-  IDPData { codeFlowUri = userUri-          , loginUser = Nothing-          , idpName = Linkedin-          , oauth2Key = linkedinKey-          , toFetchAccessToken = postAT-          , userApiUri = ILinkedin.userInfoUri-          , toLoginUser = ILinkedin.toLoginUser-          }--}

@@ -1,71 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Okta 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 Okta = Okta-  deriving (Show, Generic, Eq)--instance Hashable Okta--instance IDP Okta--instance HasLabel Okta--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-    return (second toLoginUser re)---- | https://developer.okta.com/docs/reference/api/oidc/#request-parameters--- Okta Org AS doesn't support consent--- Okta Custom AS does support consent via config (what scope shall prompt consent)----instance HasAuthUri Okta where-  authUri _ =-    createCodeUri-      oktaKey-      [ ("state", "Okta.test-state-123"),-        ( "scope",-          "openid profile"-          -- , "openid profile offline_access okta.users.read.self okta.users.read"-        ),-        ("prompt", "login consent")-      ]--data OktaUser = OktaUser-  { name :: Text,-    preferredUsername :: Text-  }-  deriving (Show, Generic)--instance FromJSON OktaUser where-  parseJSON =-    genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}--userInfoUri :: URI-userInfoUri = [uri|https://hw2.trexcloud.com/oauth2/v1/userinfo|]---- userInfoUri = [uri|https://dev-148986.oktapreview.com/oauth2/v1/userinfo|]--toLoginUser :: OktaUser -> LoginUser-toLoginUser ouser = LoginUser {loginUserName = name ouser}

@@ -1,63 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Slack 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 Slack = Slack-  deriving (Show, Generic, Eq)--instance Hashable Slack--instance IDP Slack--instance HasLabel Slack--instance HasTokenReq Slack where-  tokenReq _ mgr = fetchAccessToken mgr slackKey--instance HasTokenRefreshReq Slack where-  tokenRefreshReq _ mgr = refreshAccessToken mgr slackKey--instance HasUserReq Slack where-  userReq _ mgr at = do-    re <- authGetJSON mgr at userInfoUri-    return (second toLoginUser re)--instance HasAuthUri Slack where-  authUri _ =-    createCodeUri-      slackKey-      [ ("state", "Slack.test-state-123"),-        ( "scope",-          "openid profile email"-        )-      ]--data SlackUser = SlackUser-  { name :: Text,-    email :: Text-  }-  deriving (Show, Generic)--instance FromJSON SlackUser where-  parseJSON =-    genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}--userInfoUri :: URI-userInfoUri = [uri|https://slack.com/api/openid.connect.userInfo|]--toLoginUser :: SlackUser -> LoginUser-toLoginUser ouser = LoginUser {loginUserName = name ouser}

@@ -1,77 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE RecordWildCards   #-}--{--  NOTES: stackexchange API spec and its document just sucks!--}-module IDP.StackExchange where-import           Data.Aeson-import           Data.Bifunctor-import           Data.ByteString            (ByteString)-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           Lens.Micro-import           Network.OAuth.OAuth2-import           Types-import           URI.ByteString-import           URI.ByteString.QQ-import           Utils--data StackExchange = StackExchange deriving (Show, Generic, Eq)--instance Hashable StackExchange--instance IDP StackExchange--instance HasLabel StackExchange--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-              (userInfoUri `appendStackExchangeAppKey` stackexchangeAppKey)-    return (re >>= (bimap BSL.pack toLoginUser . eitherDecode))--instance HasAuthUri StackExchange where-  authUri _ = createCodeUri stackexchangeKey [ ("state", "StackExchange.test-state-123")-                                          ]--data StackExchangeResp = StackExchangeResp { hasMore :: Bool-                                           , quotaMax :: Integer-                                           , quotaRemaining :: Integer-                                           , items :: [StackExchangeUser]-                                           } deriving (Show, Generic)--data StackExchangeUser = StackExchangeUser { userId       :: Integer-                                           , displayName  :: Text-                                           , profileImage :: Text-                                           } deriving (Show, Generic)--instance FromJSON StackExchangeResp where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }-instance FromJSON StackExchangeUser where-    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }--userInfoUri :: URI-userInfoUri = [uri|https://api.stackexchange.com/2.2/me?site=stackoverflow|]--toLoginUser :: StackExchangeResp -> LoginUser-toLoginUser StackExchangeResp {..} =-  case items of-    [] -> LoginUser { loginUserName = TL.pack "Cannot find stackexchange user" }-    (user:_) -> LoginUser { loginUserName = displayName user }--appendStackExchangeAppKey :: URI -> ByteString -> URI-appendStackExchangeAppKey useruri k =-  over (queryL . queryPairsL) (\query -> query ++ [("key", k)]) useruri

@@ -1,71 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module IDP.Weibo where--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--data Weibo = Weibo deriving (Show, Generic, Eq)--instance Hashable Weibo--instance IDP Weibo--instance HasLabel Weibo--instance HasTokenRefreshReq Weibo where-  tokenRefreshReq _ mgr = refreshAccessToken mgr weiboKey--instance HasTokenReq Weibo where-  tokenReq _ mgr = fetchAccessToken mgr weiboKey---- fetch user info via--- GET--- access token in query param only-instance HasUserReq Weibo where-  userReq _ mgr at = do-    re <- authGetBS2 mgr at userInfoUri-    return (re >>= (bimap BSL.pack toLoginUser . eitherDecode))--instance HasAuthUri Weibo where-  authUri _ =-    createCodeUri-      weiboKey-      [ ("state", "Weibo.test-state-123")-      ]---- | 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}-  deriving (Show, Generic)--instance FromJSON WeiboUID where-  parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}--instance FromJSON WeiboUser where-  parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = camelTo2 '_'}--userInfoUri :: URI-userInfoUri = [uri|https://api.weibo.com/2/account/get_uid.json|]--toLoginUser :: WeiboUID -> LoginUser-toLoginUser ouser = LoginUser {loginUserName = TL.pack $ show $ uid ouser}

@@ -1,69 +0,0 @@-{-# 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, Eq)--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 }-

@@ -1,141 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module Keys where--import           Data.ByteString                ( ByteString )-import           Network.OAuth.OAuth2-import           URI.ByteString.QQ--weiboKey :: OAuth2-weiboKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://127.0.0.1:9988/oauthCallback|]-  , oauth2AuthorizeEndpoint  = [uri|https://api.weibo.com/oauth2/authorize|]-  , oauth2TokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]-  }---- | http://developer.github.com/v3/oauth/-githubKey :: OAuth2-githubKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://127.0.0.1:9988/githubCallback|]-  , oauth2AuthorizeEndpoint  = [uri|https://github.com/login/oauth/authorize|]-  , oauth2TokenEndpoint =-    [uri|https://github.com/login/oauth/access_token|]-  }---- | oauthCallback = Just "https://developers.google.com/oauthplayground"-googleKey :: OAuth2-googleKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx.apps.googleusercontent.com"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://127.0.0.1:9988/googleCallback|]-  , oauth2AuthorizeEndpoint  = [uri|https://accounts.google.com/o/oauth2/auth|]-  , oauth2TokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]-  }--facebookKey :: OAuth2-facebookKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://t.haskellcn.org/cb|]-  , oauth2AuthorizeEndpoint  = [uri|https://www.facebook.com/dialog/oauth|]-  , oauth2TokenEndpoint =-    [uri|https://graph.facebook.com/v2.3/oauth/access_token|]-  }--doubanKey :: OAuth2-doubanKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9999/oauthCallback|]-  , oauth2AuthorizeEndpoint  = [uri|https://www.douban.com/service/auth2/auth|]-  , oauth2TokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]-  }--fitbitKey :: OAuth2-fitbitKey = OAuth2-  { oauth2ClientId            = "xxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  = [uri|https://www.fitbit.com/oauth2/authorize|]-  , oauth2TokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]-  }---- fix key from your application edit page--- https://stackapps.com/apps/oauth-stackexchangeAppKey :: ByteString-stackexchangeAppKey = "xxxxxx"--stackexchangeKey :: OAuth2-stackexchangeKey = OAuth2-  { oauth2ClientId            = "xx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://c.haskellcn.org/cb|]-  , oauth2AuthorizeEndpoint  = [uri|https://stackexchange.com/oauth|]-  , oauth2TokenEndpoint =-    [uri|https://stackexchange.com/oauth/access_token|]-  }-dropboxKey :: OAuth2-dropboxKey = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  = [uri|https://www.dropbox.com/1/oauth2/authorize|]-  , oauth2TokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]-  }--oktaKey :: OAuth2-oktaKey = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  =-    [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|]-  , oauth2TokenEndpoint =-    [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|]-  }--azureADKey :: OAuth2-azureADKey = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  =-    [uri|https://login.windows.net/common/oauth2/authorize|]-  , oauth2TokenEndpoint =-    [uri|https://login.windows.net/common/oauth2/token|]-  }--zohoKey :: OAuth2-zohoKey = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  = [uri|https://accounts.zoho.com/oauth/v2/auth|]-  , oauth2TokenEndpoint = [uri|https://accounts.zoho.com/oauth/v2/token|]-  }--auth0Key :: OAuth2-auth0Key = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  = [uri|https://foo.auth0.com/authorize|]-  , oauth2TokenEndpoint = [uri|https://foo.auth0.com/oauth/token|]-  }---- https://api.slack.com/authentication/sign-in-with-slack--- https://slack.com/.well-known/openid-configuration-slackKey :: OAuth2-slackKey =-  OAuth2-    { oauth2ClientId = ""-    , oauth2ClientSecret = Just ""-    , oauth2RedirectUri = Just [uri|http://localhost:9988/oauth2/callback|]-    , oauth2AuthorizeEndpoint = [uri|https://slack.com/openid/connect/authorize|]-    , oauth2TokenEndpoint = [uri|https://slack.com/api/openid.connect.token|]-    }

@@ -1,141 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module Keys where--import           Data.ByteString                ( ByteString )-import           Network.OAuth.OAuth2-import           URI.ByteString.QQ--weiboKey :: OAuth2-weiboKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://127.0.0.1:9988/oauthCallback|]-  , oauth2AuthorizeEndpoint  = [uri|https://api.weibo.com/oauth2/authorize|]-  , oauth2TokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|]-  }---- | http://developer.github.com/v3/oauth/-githubKey :: OAuth2-githubKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://127.0.0.1:9988/githubCallback|]-  , oauth2AuthorizeEndpoint  = [uri|https://github.com/login/oauth/authorize|]-  , oauth2TokenEndpoint =-    [uri|https://github.com/login/oauth/access_token|]-  }---- | oauthCallback = Just "https://developers.google.com/oauthplayground"-googleKey :: OAuth2-googleKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx.apps.googleusercontent.com"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://127.0.0.1:9988/googleCallback|]-  , oauth2AuthorizeEndpoint  = [uri|https://accounts.google.com/o/oauth2/auth|]-  , oauth2TokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|]-  }--facebookKey :: OAuth2-facebookKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://t.haskellcn.org/cb|]-  , oauth2AuthorizeEndpoint  = [uri|https://www.facebook.com/dialog/oauth|]-  , oauth2TokenEndpoint =-    [uri|https://graph.facebook.com/v2.3/oauth/access_token|]-  }--doubanKey :: OAuth2-doubanKey = OAuth2-  { oauth2ClientId            = "xxxxxxxxxxxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9999/oauthCallback|]-  , oauth2AuthorizeEndpoint  = [uri|https://www.douban.com/service/auth2/auth|]-  , oauth2TokenEndpoint = [uri|https://www.douban.com/service/auth2/token|]-  }--fitbitKey :: OAuth2-fitbitKey = OAuth2-  { oauth2ClientId            = "xxxxxx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  = [uri|https://www.fitbit.com/oauth2/authorize|]-  , oauth2TokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|]-  }---- fix key from your application edit page--- https://stackapps.com/apps/oauth-stackexchangeAppKey :: ByteString-stackexchangeAppKey = "xxxxxx"--stackexchangeKey :: OAuth2-stackexchangeKey = OAuth2-  { oauth2ClientId            = "xx"-  , oauth2ClientSecret        = Just "xxxxxxxxxxxxxxx"-  , oauth2RedirectUri            = Just [uri|http://c.haskellcn.org/cb|]-  , oauth2AuthorizeEndpoint  = [uri|https://stackexchange.com/oauth|]-  , oauth2TokenEndpoint =-    [uri|https://stackexchange.com/oauth/access_token|]-  }-dropboxKey :: OAuth2-dropboxKey = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  = [uri|https://www.dropbox.com/1/oauth2/authorize|]-  , oauth2TokenEndpoint = [uri|https://api.dropboxapi.com/oauth2/token|]-  }--oktaKey :: OAuth2-oktaKey = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  =-    [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|]-  , oauth2TokenEndpoint =-    [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|]-  }--azureADKey :: OAuth2-azureADKey = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  =-    [uri|https://login.windows.net/common/oauth2/authorize|]-  , oauth2TokenEndpoint =-    [uri|https://login.windows.net/common/oauth2/token|]-  }--zohoKey :: OAuth2-zohoKey = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  = [uri|https://accounts.zoho.com/oauth/v2/auth|]-  , oauth2TokenEndpoint = [uri|https://accounts.zoho.com/oauth/v2/token|]-  }--auth0Key :: OAuth2-auth0Key = OAuth2-  { oauth2ClientId            = "xxx"-  , oauth2ClientSecret        = Just "xxx"-  , oauth2RedirectUri            = Just [uri|http://localhost:9988/oauth2/callback|]-  , oauth2AuthorizeEndpoint  = [uri|https://foo.auth0.com/authorize|]-  , oauth2TokenEndpoint = [uri|https://foo.auth0.com/oauth/token|]-  }---- https://api.slack.com/authentication/sign-in-with-slack--- https://slack.com/.well-known/openid-configuration-slackKey :: OAuth2-slackKey =-  OAuth2-    { oauth2ClientId = ""-    , oauth2ClientSecret = Just ""-    , oauth2RedirectUri = Just [uri|http://localhost:9988/oauth2/callback|]-    , oauth2AuthorizeEndpoint = [uri|https://slack.com/openid/connect/authorize|]-    , oauth2TokenEndpoint = [uri|https://slack.com/api/openid.connect.token|]-    }

@@ -1,29 +0,0 @@-* 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>--* TODO-- [ ] Split ~Key.hs~ to each IDP and read ~.env~ file if exists for override--* 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

@@ -1,38 +0,0 @@-{-# LANGUAGE RankNTypes #-}--{- mimic server side session store -}--module Session where--import           Control.Concurrent.MVar-import qualified Data.HashMap.Strict     as Map--import           Types--initCacheStore :: IO CacheStore-initCacheStore = newMVar Map.empty--allValues :: CacheStore -> IO [IDPData]-allValues store = do-  m1 <- tryReadMVar store-  return $ maybe [] Map.elems m1--removeKey :: CacheStore -> IDPLabel -> IO ()-removeKey store idpKey = do-  m1 <- takeMVar store-  let m2 = Map.update updateIdpData idpKey m1-  putMVar store m2-  where updateIdpData idpD = Just $ idpD { loginUser = Nothing }--lookupKey :: CacheStore-          -> IDPLabel-          -> IO (Maybe IDPData)-lookupKey store idpKey = do-  m1 <- tryReadMVar store-  return (Map.lookup idpKey =<< m1)--insertIDPData :: CacheStore -> IDPData -> IO ()-insertIDPData store val = do-  m1 <- takeMVar store-  let m2 = Map.insert (idpDisplayLabel val) val m1-  putMVar store m2

@@ -1,116 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# 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 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--type IDPLabel = Text--type CacheStore = MVar (Map.HashMap IDPLabel IDPData)---- * type class for defining a IDP-----class (Hashable a, Show a) => IDP a--class (IDP a) => HasLabel a where-  idpLabel :: a -> IDPLabel-  idpLabel = TL.pack . show--class (IDP a) => HasAuthUri a where-  authUri :: a -> Text--class (IDP a) => HasTokenReq a where-  tokenReq :: a -> Manager -> ExchangeToken -> IO (OAuth2Result TR.Errors OAuth2Token)--class (IDP a) => 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.-    ( HasTokenRefreshReq a,-      HasTokenReq a,-      HasUserReq a,-      HasLabel a,-      HasAuthUri a-    ) =>-    IDPApp a---- dummy oauth2 request error----data Errors-  = SomeRandomError-  deriving (Show, Eq, Generic)--instance FromJSON Errors where-  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True}--newtype LoginUser = LoginUser-  { loginUserName :: Text-  }-  deriving (Eq, Show)--data IDPData = IDPData-  { codeFlowUri :: Text,-    loginUser :: Maybe LoginUser,-    oauth2Token :: Maybe OAuth2Token,-    idpDisplayLabel :: IDPLabel-  }---- simplify use case to only allow one idp instance for now.-instance Eq IDPData where-  a == b = idpDisplayLabel a == idpDisplayLabel b--instance Ord IDPData where-  a `compare` b = idpDisplayLabel a `compare` idpDisplayLabel b--newtype TemplateData = TemplateData-  { idpTemplateData :: [IDPData]-  }-  deriving (Eq)---- * Mustache instances--instance ToMustache IDPData where-  toMustache t' =-    M.object-      [ "codeFlowUri" ~> codeFlowUri t',-        "isLogin" ~> isJust (loginUser t'),-        "user" ~> loginUser t',-        "name" ~> TL.unpack (idpDisplayLabel t')-      ]--instance ToMustache LoginUser where-  toMustache t' =-    M.object-      ["name" ~> loginUserName t']--instance ToMustache TemplateData where-  toMustache td' =-    M.object-      [ "idps" ~> idpTemplateData td'-      ]

@@ -1,37 +0,0 @@-module Utils where--import qualified Data.Aeson                 as Aeson-import           Data.ByteString            (ByteString)-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.Text.Encoding         as TE-import           Data.Text.Lazy             (Text)-import qualified Data.Text.Lazy             as TL--import           Network.OAuth.OAuth2-import           URI.ByteString-import           Web.Scotty.Internal.Types--tlToBS :: TL.Text -> ByteString-tlToBS = TE.encodeUtf8 . TL.toStrict--bslToText :: BSL.ByteString -> Text-bslToText = TL.pack . BSL.unpack--paramValue :: Text -> [Param] -> [Text]-paramValue key = fmap snd . filter (hasParam key)--hasParam :: Text -> Param -> Bool-hasParam t = (== t) . fst--parseValue :: Aeson.FromJSON a => Maybe Aeson.Value -> Maybe a-parseValue Nothing = Nothing-parseValue (Just a) = case Aeson.fromJSON a of-  Aeson.Error _   -> Nothing-  Aeson.Success b -> Just b--createCodeUri :: OAuth2-  -> [(ByteString, ByteString)]-  -> Text-createCodeUri key params = TL.fromStrict $ TE.decodeUtf8 $ serializeURIRef'-  $ appendQueryParams params-  $ authorizationUrl key

@@ -1,39 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Views where--import           Control.Monad.IO.Class (liftIO)-import           Data.List              (sort)-import qualified Data.Text.Lazy         as TL-import           Text.Mustache-import           Text.Parsec.Error-import           Web.Scotty--import           Types--type CookieUser = String--tpl :: FilePath  -> IO (Either ParseError Template)-tpl f = automaticCompile ["./example/templates", "./templates"] (f ++ ".mustache")--tplS :: FilePath-     -> [IDPData]-     -> IO TL.Text-tplS path xs = do-  template <- tpl path-  case template of-    Left e   -> return-                $ TL.unlines-                $ map TL.pack [ "can not parse template " ++ path ++ ".mustache" , show e ]-    Right t' -> return $ TL.fromStrict $ substitute t' (TemplateData $ sort xs)--tplH :: FilePath-     -> [IDPData]-     -> ActionM ()-tplH path xs = do-  s <- liftIO (tplS path xs)-  html s---overviewTpl :: [IDPData] -> ActionM ()-overviewTpl = tplH "index"

@@ -1,11 +0,0 @@-body {-    padding: 10px 50px;-}--.login-with {-    margin: 10px 0;-    padding: 10px;-    border: 1px solid grey;-    border-radius: 5px;-    width: 500px;-}

@@ -1,6 +0,0 @@-module Main where--import           App (app)--main :: IO ()-main = app

@@ -1,32 +0,0 @@-<html>-    <head>-        <link href="/main.css" rel="stylesheet"/>-    </head>-    <body>-        <h1>Hello OAuth2</h1>-        {{#idps}}-        <section class="login-with">--            {{^isLogin}}-            <a href="{{codeFlowUri}}">Sign in with {{name}}</a>-            {{/isLogin}}--            {{#isLogin}}-            <h2>Welcome to {{name}}</h2>-            {{#user}}-            <div class="result">Hello, {{name}}</div>-            {{/user}}-            <a href="/logout?idp={{name}}">Logout</a>-            <a href="/refresh?idp={{name}}">Refresh</a>-            {{/isLogin}}--        </section>-        {{/idps}}-        <h2>Notes</h2>-        <ol>-            <li>for StackExchange, the callback domain is localhost, have manually add port 9988.</li>-            <li>for Slack, the callback url has to be https and without any port hence need manual intervention. (TODO: add tls to the server)</li>-        </ol>-        </p>-    </body>-</html>

@@ -1,7 +1,7 @@ Cabal-version: 2.4 Name:                hoauth2 -- http://wiki.haskell.org/Package_versioning_policy-Version:             2.1.0+Version:             2.2.0  Synopsis:            Haskell OAuth2 authentication client @@ -36,37 +36,12 @@ Stability:           Beta Tested-With:         GHC <= 8.10.7 -Extra-source-files: README.md-                    example/Keys.hs.sample-                    example/IDP/AzureAD.hs-                    example/IDP/Google.hs-                    example/IDP/Weibo.hs-                    example/IDP/Github.hs-                    example/IDP/Facebook.hs-                    example/IDP/Fitbit.hs-                    example/IDP/Douban.hs-                    example/IDP/Linkedin.hs-                    example/IDP/Slack.hs-                    example/IDP/Auth0.hs-                    example/IDP.hs-                    example/App.hs-                    example/Session.hs-                    example/Types.hs-                    example/Utils.hs-                    example/Views.hs-                    example/main.hs-                    example/README.org-                    example/templates/index.mustache-                    example/assets/main.css+Extra-source-files: README.org  Source-Repository head   Type:     git   Location: git://github.com/freizl/hoauth2.git -Flag test-  Description: Build the executables-  Default: False- Library   hs-source-dirs:   src   default-language: Haskell2010@@ -77,70 +52,20 @@                    Network.OAuth.OAuth2.AuthorizationRequest    Build-Depends: base                 >= 4     && < 5,-                 binary               >= 0.8.3.0 && < 0.8.9,+                 binary               >= 0.8.3 && < 0.8.9,                  text                 >= 0.11  && < 1.3,                  bytestring           >= 0.9   && < 0.11,                  http-conduit         >= 2.1   && < 2.4,-                 http-types           >= 0.11   && < 0.13,-                 aeson                >= 2.0 && < 2.1,-                 unordered-containers >= 0.2.5,-                 uri-bytestring       >= 0.2.3.1 && < 0.4,+                 http-types           >= 0.11  && < 0.13,+                 aeson                >= 2.0   && < 2.1,+                 transformers         >= 0.5   && < 0.6,+                 unordered-containers >= 0.2.5 && < 0.3,+                 uri-bytestring       >= 0.2.3 && < 0.4,                  uri-bytestring-aeson >= 0.1   && < 0.2,                  microlens            >= 0.4.0 && < 0.5,-                 hashable >= 1.2.6 && < 1.5.0,+                 hashable             >= 1.2.6 && < 1.5.0,                  exceptions           >= 0.8.3 && < 0.11    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields                -fno-warn-unused-do-bind -Executable demo-server-  if flag(test)-    Buildable: True-  else-    Buildable: False--  main-is:             main.hs-  other-modules:       IDP,-                       App-                       IDP.AzureAD-                       IDP.Douban-                       IDP.Dropbox-                       IDP.Facebook-                       IDP.Fitbit-                       IDP.Github-                       IDP.Google-                       IDP.Slack-                       IDP.Auth0-                       IDP.Okta-                       IDP.StackExchange-                       IDP.Weibo-                       IDP.Linkedin-                       IDP.ZOHO-                       Keys-                       Session-                       Types-                       Utils-                       Views-  hs-source-dirs:      example-  default-language:    Haskell2010-  build-depends:       base              >= 4.5    && < 5,-                       text              >= 0.11   && < 1.3,-                       bytestring        >= 0.9    && < 0.11,-                       uri-bytestring    >= 0.2.3.1 && < 0.4,-                       http-conduit      >= 2.1    && < 2.4,-                       http-types        >= 0.11    && < 0.13,-                       wai               >= 3.2    && < 3.3,-                       warp              >= 3.2    && < 3.4,-                       aeson             >= 2.0 && < 2.1,-                       microlens            >= 0.4.0 && < 0.5,-                       unordered-containers >= 0.2.5,-                       wai-middleware-static >= 0.8.1 && < 0.10.0,-                       mustache >= 2.2.3 && < 2.5.0,-                       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.5.0,-                       hoauth2--  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields-               -fno-warn-unused-do-bind -fno-warn-orphans

@@ -22,10 +22,11 @@   authRequest ) where +import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except import qualified Data.Aeson.KeyMap as KeyMap import           qualified Data.Aeson.Key as Key import           Data.Aeson-import           Data.Bifunctor                    (first) import qualified Data.ByteString.Char8             as BS import qualified Data.ByteString.Lazy.Char8        as BSL import           Data.Maybe@@ -53,7 +54,7 @@ fetchAccessToken :: Manager                                   -- ^ HTTP connection manager                    -> OAuth2                                  -- ^ OAuth Data                    -> ExchangeToken                           -- ^ OAuth2 Code-                   -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token+                   -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -- ^ Access Token fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body                            where (uri, body) = accessTokenUrl oa code @@ -62,11 +63,13 @@ fetchAccessToken2 :: Manager                                   -- ^ HTTP connection manager                    -> OAuth2                                  -- ^ OAuth Data                    -> ExchangeToken                           -- ^ OAuth 2 Tokens-                   -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token+                   -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -- ^ Access Token fetchAccessToken2 mgr oa code = do   let (url, body1) = accessTokenUrl oa code-  let secret x = [("client_secret", T.encodeUtf8 x)]-  let extraBody = ("client_id", T.encodeUtf8 $ oauth2ClientId oa) : maybe [] secret (oauth2ClientSecret oa)+  let extraBody = [+        ("client_id", T.encodeUtf8 $ oauth2ClientId oa),+        ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)+        ]   doJSONPostRequest mgr oa url (extraBody ++ body1)  -- | Fetch a new AccessToken with the Refresh Token with authentication in request header.@@ -80,7 +83,7 @@ refreshAccessToken :: Manager                         -- ^ HTTP connection manager.                      -> OAuth2                       -- ^ OAuth context                      -> RefreshToken                 -- ^ refresh token gained after authorization-                     -> IO (OAuth2Result TR.Errors OAuth2Token)+                     -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token refreshAccessToken manager oa token = doJSONPostRequest manager oa uri body                               where (uri, body) = refreshAccessTokenUrl oa token @@ -89,11 +92,13 @@ refreshAccessToken2 :: Manager                         -- ^ HTTP connection manager.                      -> OAuth2                       -- ^ OAuth context                      -> RefreshToken                 -- ^ refresh token gained after authorization-                     -> IO (OAuth2Result TR.Errors OAuth2Token)+                     -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token refreshAccessToken2 manager oa token = do   let (uri, body) = refreshAccessTokenUrl oa token-  let secret x = [("client_secret", T.encodeUtf8 x)]-  let extraBody = ("client_id", T.encodeUtf8 $ oauth2ClientId oa) : maybe [] secret (oauth2ClientSecret oa)+  let extraBody = [+        ("client_id", T.encodeUtf8 $ oauth2ClientId oa),+        ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)+        ]   doJSONPostRequest manager oa uri (extraBody ++ body)  -- | Conduct post request and return response as JSON.@@ -102,53 +107,48 @@                   -> OAuth2                              -- ^ OAuth options                   -> URI                                 -- ^ The URL                   -> PostBody                            -- ^ request body-                  -> IO (OAuth2Result err a)             -- ^ Response as JSON-doJSONPostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body)+                  -> ExceptT (OAuth2Error err) IO a -- ^ Response as JSON+doJSONPostRequest manager oa uri body = do+  resp <- doSimplePostRequest manager oa uri body+  case parseResponseFlexible resp of+    Right obj -> return obj+    Left e -> throwE e  -- | Conduct post request. doSimplePostRequest :: FromJSON err => Manager                 -- ^ HTTP connection manager.                        -> OAuth2                               -- ^ OAuth options                        -> URI                                  -- ^ URL                        -> PostBody                             -- ^ Request body.-                       -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString-doSimplePostRequest manager oa url body = fmap handleOAuth2TokenResponse go-                                  where go = do-                                             req <- uriToRequest url-                                             let addBasicAuth = case oauth2ClientSecret oa of-                                                   (Just secret) -> applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 secret)-                                                   Nothing -> id-                                                 req' = (addBasicAuth . updateRequestHeaders Nothing) req-                                             httpLbs (urlEncodedBody body req') manager+                       -> ExceptT  (OAuth2Error err) IO  BSL.ByteString -- ^ Response as ByteString+doSimplePostRequest manager oa url body =+  ExceptT $ fmap handleOAuth2TokenResponse go+  where+    addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauth2ClientId oa) (T.encodeUtf8 $ oauth2ClientSecret oa)+    go = do+          req <- uriToRequest url+          let req' = (addBasicAuth . updateRequestHeaders Nothing) req+          httpLbs (urlEncodedBody body req') manager  -- | Parses a @Response@ to to @OAuth2Result@-handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString+handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> Either (OAuth2Error err) BSL.ByteString handleOAuth2TokenResponse rsp =     if HT.statusIsSuccessful (responseStatus rsp)         then Right $ responseBody rsp         else Left $ parseOAuth2Error (responseBody rsp)  -- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String.-parseResponseFlexible :: FromJSON err => FromJSON a-                         => OAuth2Result err BSL.ByteString-                         -> OAuth2Result err a-parseResponseFlexible r = case parseResponseJSON r of-                           Left _ -> parseResponseString r-                           x      -> x--parseResponseJSON :: (FromJSON err, FromJSON a)-              => OAuth2Result err BSL.ByteString-              -> OAuth2Result err a-parseResponseJSON (Left b) = Left b-parseResponseJSON (Right b) = case eitherDecode b of-                            Left e  -> Left $ mkDecodeOAuth2Error b e-                            Right x -> Right x+parseResponseFlexible :: (FromJSON err, FromJSON a)+                         => BSL.ByteString+                         -> Either (OAuth2Error err) a+parseResponseFlexible r = case eitherDecode r of+                           Left _   -> parseResponseString r+                           Right x  -> Right x  -- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String parseResponseString :: (FromJSON err, FromJSON a)-              => OAuth2Result err BSL.ByteString-              -> OAuth2Result err a-parseResponseString (Left b) = Left b-parseResponseString (Right b) = case parseQuery $ BSL.toStrict b of+              => BSL.ByteString+              -> Either (OAuth2Error err) a+parseResponseString b = case parseQuery $ BSL.toStrict b of                               [] -> Left errorMessage                               a -> case fromJSON $ queryToValue a of                                     Error _   -> Left errorMessage@@ -160,55 +160,70 @@  -------------------------------------------------- -- * AUTH requests+-- Making request with Access Token injected into header or request body.+-- --------------------------------------------------  -- | Conduct an authorized GET request and return response as JSON.+--   Inject Access Token to Authorization Header.+-- authGetJSON :: (FromJSON b)                  => Manager                 -- ^ HTTP connection manager.                  -> AccessToken                  -> URI-                 -> IO (Either BSL.ByteString b) -- ^ Response as JSON+                 -> ExceptT BSL.ByteString IO b -- ^ Response as JSON authGetJSON manager t uri = do   resp <- authGetBS manager t uri-  return (resp >>= (first BSL.pack . eitherDecode))+  case eitherDecode resp of+    Right obj -> return obj+    Left e -> throwE $ BSL.pack e  -- | Conduct an authorized GET request.+--   Inject Access Token to Authorization Header.+-- authGetBS :: Manager                 -- ^ HTTP connection manager.              -> AccessToken              -> URI-             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString+             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString authGetBS manager token url = do   req <- uriToRequest url   authRequest req upReq manager   where upReq = updateRequestHeaders (Just token) . setMethod HT.GET --- | same to 'authGetBS' but set access token to query parameter rather than header+-- | Same to 'authGetBS' but set access token to query parameter rather than header+-- authGetBS2 :: Manager                -- ^ HTTP connection manager.              -> AccessToken              -> URI-             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString+             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString authGetBS2 manager token url = do-  req <- uriToRequest (url `appendAccessToken` token)+  req <- liftIO $ uriToRequest (url `appendAccessToken` token)   authRequest req upReq manager   where upReq = updateRequestHeaders Nothing . setMethod HT.GET  -- | Conduct POST request and return response as JSON.+--   Inject Access Token to Authorization Header and request body.+-- authPostJSON :: (FromJSON b)                  => Manager                 -- ^ HTTP connection manager.                  -> AccessToken                  -> URI                  -> PostBody-                 -> IO (Either BSL.ByteString b) -- ^ Response as JSON+                 -> ExceptT BSL.ByteString IO b -- ^ Response as JSON authPostJSON manager t uri pb = do   resp <- authPostBS manager t uri pb-  return (resp >>= (first BSL.pack . eitherDecode))+  case eitherDecode resp of+    Right obj -> return obj+    Left e -> throwE $ BSL.pack e  -- | Conduct POST request.+--   Inject Access Token to http header (Authorization) and request body.+-- authPostBS :: Manager                -- ^ HTTP connection manager.              -> AccessToken              -> URI              -> PostBody-             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString+             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString authPostBS manager token url pb = do   req <- uriToRequest url   authRequest req upReq manager@@ -216,12 +231,13 @@         upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST         upReq = upHeaders . upBody --- | Conduct POST request with access token in the request body rather header+-- | Conduct POST request with access token only in the request body but header.+-- authPostBS2 :: Manager               -- ^ HTTP connection manager.              -> AccessToken              -> URI              -> PostBody-             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString+             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString authPostBS2 manager token url pb = do   req <- uriToRequest url   authRequest req upReq manager@@ -229,11 +245,11 @@         upHeaders = updateRequestHeaders Nothing . setMethod HT.POST         upReq = upHeaders . upBody --- | Conduct POST request with access token in the header and null in body+-- | Conduct POST request with access token only in the header and not in body authPostBS3 :: Manager               -- ^ HTTP connection manager.              -> AccessToken              -> URI-             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString+             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString authPostBS3 manager token url = do   req <- uriToRequest url   authRequest req upReq manager@@ -247,8 +263,8 @@ authRequest :: Request          -- ^ Request to perform                -> (Request -> Request)          -- ^ Modify request before sending                -> Manager                       -- ^ HTTP connection manager.-               -> IO (Either BSL.ByteString BSL.ByteString)-authRequest req upReq manage = handleResponse <$> httpLbs (upReq req) manage+               -> ExceptT BSL.ByteString IO BSL.ByteString+authRequest req upReq manage = ExceptT $ handleResponse <$> httpLbs (upReq req) manage  -------------------------------------------------- -- * Utilities

@@ -36,13 +36,9 @@ --------------------------------------------------  -- | Query Parameter Representation--- TODO: fix typo in OAuthorizeEndpoint--- rename AccessToken to TokenEndpoint--- rename callback to redirectUri- data OAuth2 = OAuth2   { oauth2ClientId :: Text,-    oauth2ClientSecret :: Maybe Text,+    oauth2ClientSecret :: Text,     oauth2AuthorizeEndpoint :: URIRef Absolute,     oauth2TokenEndpoint :: URIRef Absolute,     oauth2RedirectUri :: Maybe ( URIRef Absolute )@@ -134,9 +130,6 @@ -- * Types Synonym  ------------------------------------------------------ | Is either 'Left' containing an error or 'Right' containg a result-type OAuth2Result err a = Either (OAuth2Error err) a  -- | type synonym of post body content type PostBody = [(BS.ByteString, BS.ByteString)]