hoauth2-1.14.0/0000755000000000000000000000000007346545000011340 5ustar0000000000000000hoauth2-1.14.0/LICENSE0000644000000000000000000000276707346545000012361 0ustar0000000000000000Copyright (c)2012-present, Haisheng Wu All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Haisheng Wu nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hoauth2-1.14.0/README.md0000755000000000000000000000134107346545000012621 0ustar0000000000000000[![Build 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 example app - `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` - open ## 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. hoauth2-1.14.0/Setup.hs0000644000000000000000000000005607346545000012775 0ustar0000000000000000import Distribution.Simple main = defaultMain hoauth2-1.14.0/example/0000755000000000000000000000000007346545000012773 5ustar0000000000000000hoauth2-1.14.0/example/App.hs0000644000000000000000000001412507346545000014052 0ustar0000000000000000{-# 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: " `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) hoauth2-1.14.0/example/App.hs0000755000000000000000000001412507346545000014055 0ustar0000000000000000{-# 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: " `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) hoauth2-1.14.0/example/IDP.hs0000644000000000000000000000301607346545000013743 0ustar0000000000000000 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 -- 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 ] 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) hoauth2-1.14.0/example/IDP.hs0000755000000000000000000000301607346545000013746 0ustar0000000000000000 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 -- 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 ] 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) hoauth2-1.14.0/example/IDP/0000755000000000000000000000000007346545000013407 5ustar0000000000000000hoauth2-1.14.0/example/IDP/AzureAD.hs0000644000000000000000000000310607346545000015236 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/AzureAD.hs0000755000000000000000000000310607346545000015241 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Douban.hs0000644000000000000000000000274207346545000015160 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Douban.hs0000755000000000000000000000274207346545000015163 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Dropbox.hs0000644000000000000000000000353007346545000015361 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Facebook.hs0000644000000000000000000000323307346545000015455 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Facebook.hs0000755000000000000000000000323307346545000015460 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Fitbit.hs0000644000000000000000000000330407346545000015164 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module IDP.Fitbit where import Control.Monad (mzero) import Data.Aeson import Data.Bifunctor import Data.Hashable import Data.Text.Lazy (Text) import GHC.Generics import Keys import Network.OAuth.OAuth2 import Types import URI.ByteString import URI.ByteString.QQ import Utils data Fitbit = Fitbit deriving (Show, Generic) instance Hashable Fitbit instance IDP Fitbit instance HasLabel Fitbit instance HasTokenReq Fitbit where tokenReq _ mgr = fetchAccessToken mgr fitbitKey instance 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 } hoauth2-1.14.0/example/IDP/Fitbit.hs0000755000000000000000000000330407346545000015167 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module IDP.Fitbit where import Control.Monad (mzero) import Data.Aeson import Data.Bifunctor import Data.Hashable import Data.Text.Lazy (Text) import GHC.Generics import Keys import Network.OAuth.OAuth2 import Types import URI.ByteString import URI.ByteString.QQ import Utils data Fitbit = Fitbit deriving (Show, Generic) instance Hashable Fitbit instance IDP Fitbit instance HasLabel Fitbit instance HasTokenReq Fitbit where tokenReq _ mgr = fetchAccessToken mgr fitbitKey instance 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 } hoauth2-1.14.0/example/IDP/Github.hs0000644000000000000000000000266207346545000015173 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Github.hs0000755000000000000000000000266207346545000015176 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Google.hs0000644000000000000000000000312007346545000015153 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Google.hs0000755000000000000000000000312007346545000015156 0ustar0000000000000000{-# 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) 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 } hoauth2-1.14.0/example/IDP/Linkedin.hs0000644000000000000000000000256707346545000015512 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {- disabled since it's not yet working. error: - serviceErrorCode:100 - message:Not enough permissions to access /me GET -} module IDP.Linkedin where import Data.Aeson import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL import GHC.Generics import Types import URI.ByteString import URI.ByteString.QQ data LinkedinUser = LinkedinUser { firstName :: Text , lastName :: Text } deriving (Show, Generic) instance FromJSON LinkedinUser where parseJSON = genericParseJSON defaultOptions userInfoUri :: URI userInfoUri = [uri|https://api.linkedin.com/v2/me|] toLoginUser :: LinkedinUser -> LoginUser toLoginUser LinkedinUser {..} = LoginUser { loginUserName = firstName `TL.append` " " `TL.append` lastName } {- mkIDPData Linkedin = let userUri = createCodeUri linkedinKey [("state", "linkedin.test-state-123")] in IDPData { codeFlowUri = userUri , loginUser = Nothing , idpName = Linkedin , oauth2Key = linkedinKey , toFetchAccessToken = postAT , userApiUri = ILinkedin.userInfoUri , toLoginUser = ILinkedin.toLoginUser } -} hoauth2-1.14.0/example/IDP/Linkedin.hs0000755000000000000000000000256707346545000015515 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {- disabled since it's not yet working. error: - serviceErrorCode:100 - message:Not enough permissions to access /me GET -} module IDP.Linkedin where import Data.Aeson import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL import GHC.Generics import Types import URI.ByteString import URI.ByteString.QQ data LinkedinUser = LinkedinUser { firstName :: Text , lastName :: Text } deriving (Show, Generic) instance FromJSON LinkedinUser where parseJSON = genericParseJSON defaultOptions userInfoUri :: URI userInfoUri = [uri|https://api.linkedin.com/v2/me|] toLoginUser :: LinkedinUser -> LoginUser toLoginUser LinkedinUser {..} = LoginUser { loginUserName = firstName `TL.append` " " `TL.append` lastName } {- mkIDPData Linkedin = let userUri = createCodeUri linkedinKey [("state", "linkedin.test-state-123")] in IDPData { codeFlowUri = userUri , loginUser = Nothing , idpName = Linkedin , oauth2Key = linkedinKey , toFetchAccessToken = postAT , userApiUri = ILinkedin.userInfoUri , toLoginUser = ILinkedin.toLoginUser } -} hoauth2-1.14.0/example/IDP/Okta.hs0000644000000000000000000000305707346545000014646 0ustar0000000000000000{-# 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) 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) instance HasAuthUri Okta where authUri _ = createCodeUri oktaKey [ ("state", "Okta.test-state-123") , ("scope", "openid profile offline_access") ] data OktaUser = OktaUser { name :: Text , preferredUsername :: Text } deriving (Show, Generic) instance FromJSON OktaUser where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } userInfoUri :: URI userInfoUri = [uri|https://dev-148986.oktapreview.com/oauth2/v1/userinfo|] toLoginUser :: OktaUser -> LoginUser toLoginUser ouser = LoginUser { loginUserName = name ouser } hoauth2-1.14.0/example/IDP/StackExchange.hs0000644000000000000000000000556207346545000016463 0ustar0000000000000000{-# 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) 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 hoauth2-1.14.0/example/IDP/Weibo.hs0000644000000000000000000000373607346545000015021 0ustar0000000000000000{-# 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) 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") ] -- TODO: http://open.weibo.com/wiki/2/users/show data WeiboUser = WeiboUser { id :: Integer , name :: Text , screenName :: Text } deriving (Show, Generic) newtype WeiboUID = WeiboUID { uid :: Integer } deriving (Show, Generic) instance FromJSON WeiboUID where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } instance FromJSON WeiboUser where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } userInfoUri :: URI userInfoUri = [uri|https://api.weibo.com/2/account/get_uid.json|] toLoginUser :: WeiboUID -> LoginUser toLoginUser ouser = LoginUser { loginUserName = TL.pack $ show $ uid ouser } hoauth2-1.14.0/example/IDP/Weibo.hs0000755000000000000000000000373607346545000015024 0ustar0000000000000000{-# 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) 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") ] -- TODO: http://open.weibo.com/wiki/2/users/show data WeiboUser = WeiboUser { id :: Integer , name :: Text , screenName :: Text } deriving (Show, Generic) newtype WeiboUID = WeiboUID { uid :: Integer } deriving (Show, Generic) instance FromJSON WeiboUID where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } instance FromJSON WeiboUser where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } userInfoUri :: URI userInfoUri = [uri|https://api.weibo.com/2/account/get_uid.json|] toLoginUser :: WeiboUID -> LoginUser toLoginUser ouser = LoginUser { loginUserName = TL.pack $ show $ uid ouser } hoauth2-1.14.0/example/IDP/ZOHO.hs0000644000000000000000000000415107346545000014523 0ustar0000000000000000{-# 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 } hoauth2-1.14.0/example/Keys.hs0000644000000000000000000001234007346545000014242 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Keys where 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|] } -- | 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|] } -- | 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|] } 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|] } 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|] } 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|] } -- fix key from your application edit page -- https://stackapps.com/apps/oauth stackexchangeAppKey :: ByteString 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|] } 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|] } 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|] } 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|] } 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|] } hoauth2-1.14.0/example/Keys.hs.sample0000755000000000000000000001234007346545000015525 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Keys where 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|] } -- | 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|] } -- | 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|] } 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|] } 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|] } 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|] } -- fix key from your application edit page -- https://stackapps.com/apps/oauth stackexchangeAppKey :: ByteString 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|] } 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|] } 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|] } 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|] } 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|] } hoauth2-1.14.0/example/README.md0000755000000000000000000000156307346545000014262 0ustar0000000000000000 * 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! hoauth2-1.14.0/example/Session.hs0000644000000000000000000000167707346545000014765 0ustar0000000000000000{-# 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 hoauth2-1.14.0/example/Session.hs0000755000000000000000000000167707346545000014770 0ustar0000000000000000{-# 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 hoauth2-1.14.0/example/Types.hs0000644000000000000000000000640507346545000014440 0ustar0000000000000000{-# 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 Data.Hashable import qualified Data.HashMap.Strict as Map import Data.Maybe import Data.Text.Lazy import qualified Data.Text.Lazy as TL import GHC.Generics import Network.HTTP.Conduit import Network.OAuth.OAuth2 import qualified Network.OAuth.OAuth2.TokenRequest as TR import Text.Mustache import qualified Text.Mustache as M type IDPLabel = Text -- TODO: how to make following type work?? -- type CacheStore = forall a. IDP a => MVar (Map.HashMap a IDPData) type CacheStore = MVar (Map.HashMap IDPLabel IDPData) -- * type class for defining a IDP -- class (Hashable a, Show a) => IDP a class (IDP a) => HasLabel a where idpLabel :: a -> IDPLabel idpLabel = TL.pack . show class (IDP a) => HasAuthUri a where authUri :: a -> Text class (IDP a) => HasTokenReq a where tokenReq :: a -> Manager -> ExchangeToken -> IO (OAuth2Result TR.Errors OAuth2Token) class (IDP a) => 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, 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' ] hoauth2-1.14.0/example/Types.hs0000755000000000000000000000640507346545000014443 0ustar0000000000000000{-# 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 Data.Hashable import qualified Data.HashMap.Strict as Map import Data.Maybe import Data.Text.Lazy import qualified Data.Text.Lazy as TL import GHC.Generics import Network.HTTP.Conduit import Network.OAuth.OAuth2 import qualified Network.OAuth.OAuth2.TokenRequest as TR import Text.Mustache import qualified Text.Mustache as M type IDPLabel = Text -- TODO: how to make following type work?? -- type CacheStore = forall a. IDP a => MVar (Map.HashMap a IDPData) type CacheStore = MVar (Map.HashMap IDPLabel IDPData) -- * type class for defining a IDP -- class (Hashable a, Show a) => IDP a class (IDP a) => HasLabel a where idpLabel :: a -> IDPLabel idpLabel = TL.pack . show class (IDP a) => HasAuthUri a where authUri :: a -> Text class (IDP a) => HasTokenReq a where tokenReq :: a -> Manager -> ExchangeToken -> IO (OAuth2Result TR.Errors OAuth2Token) class (IDP a) => 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, 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' ] hoauth2-1.14.0/example/Utils.hs0000644000000000000000000000215407346545000014431 0ustar0000000000000000module 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 hoauth2-1.14.0/example/Utils.hs0000755000000000000000000000215407346545000014434 0ustar0000000000000000module 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 hoauth2-1.14.0/example/Views.hs0000644000000000000000000000174407346545000014432 0ustar0000000000000000{-# 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" hoauth2-1.14.0/example/Views.hs0000755000000000000000000000174407346545000014435 0ustar0000000000000000{-# 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" hoauth2-1.14.0/example/assets/0000755000000000000000000000000007346545000014275 5ustar0000000000000000hoauth2-1.14.0/example/assets/main.css0000755000000000000000000000023707346545000015740 0ustar0000000000000000body { padding: 10px 50px; } .login-with { margin: 10px 0; padding: 10px; border: 1px solid grey; border-radius: 5px; width: 500px; } hoauth2-1.14.0/example/main.hs0000644000000000000000000000011007346545000014243 0ustar0000000000000000module Main where import App (app) main :: IO () main = app hoauth2-1.14.0/example/main.hs0000755000000000000000000000011007346545000014246 0ustar0000000000000000module Main where import App (app) main :: IO () main = app hoauth2-1.14.0/example/templates/0000755000000000000000000000000007346545000014771 5ustar0000000000000000hoauth2-1.14.0/example/templates/index.mustache0000755000000000000000000000145007346545000017636 0ustar0000000000000000

Hello OAuth2

{{#idps}} {{/idps}}

Notes

  1. for StackExchange, the callback domain is localhost, have manually add port 9988.

hoauth2-1.14.0/hoauth2.cabal0000644000000000000000000001277407346545000013711 0ustar0000000000000000Cabal-version: 2.4 Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy Version: 1.14.0 Synopsis: Haskell OAuth2 authentication client Description: Haskell OAuth2 authentication client. Tested with the following services: . * AzureAD: . * Google: . * Github: . * Facebook: . * Fitbit: . * StackExchange: . * DropBox: . * Weibo: . * Douban: Homepage: https://github.com/freizl/hoauth2 License: BSD-3-Clause License-file: LICENSE Author: Haisheng Wu Maintainer: Haisheng Wu Copyright: Haisheng Wu Category: Network Build-type: Simple Stability: Beta Tested-With: GHC <= 8.6.5 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.hs example/App.hs example/Session.hs example/Types.hs example/Utils.hs example/Views.hs example/main.hs example/README.md example/templates/index.mustache example/assets/main.css 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 Exposed-modules: Network.OAuth.OAuth2.HttpClient Network.OAuth.OAuth2.Internal Network.OAuth.OAuth2 Network.OAuth.OAuth2.TokenRequest Network.OAuth.OAuth2.AuthorizationRequest Build-Depends: base >= 4 && < 5, binary >= 0.8.3.0 && < 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 >= 1.3.0.0 && < 1.6, unordered-containers >= 0.2.5, uri-bytestring >= 0.2.3.1 && < 0.4, uri-bytestring-aeson >= 0.1 && < 0.2, microlens >= 0.4.0 && < 0.5, 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.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, 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.1, wai-middleware-static >= 0.8.1 && < 0.8.4, 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, hoauth2 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans hoauth2-1.14.0/src/Network/OAuth/0000755000000000000000000000000007346545000014600 5ustar0000000000000000hoauth2-1.14.0/src/Network/OAuth/OAuth2.hs0000644000000000000000000000124107346545000016234 0ustar0000000000000000------------------------------------------------------------ -- | -- Module : Network.OAuth.OAuth2 -- Description : OAuth2 client -- Copyright : (c) 2012 Haisheng Wu -- License : BSD-style (see the file LICENSE) -- Maintainer : Haisheng Wu -- Stability : alpha -- Portability : portable -- -- A lightweight oauth2 haskell binding. ------------------------------------------------------------ module Network.OAuth.OAuth2 (module Network.OAuth.OAuth2.HttpClient, module Network.OAuth.OAuth2.Internal ) where import Network.OAuth.OAuth2.HttpClient import Network.OAuth.OAuth2.Internal hoauth2-1.14.0/src/Network/OAuth/OAuth2/0000755000000000000000000000000007346545000015702 5ustar0000000000000000hoauth2-1.14.0/src/Network/OAuth/OAuth2/AuthorizationRequest.hs0000644000000000000000000000146607346545000022456 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Network.OAuth.OAuth2.AuthorizationRequest where import Data.Aeson import GHC.Generics instance FromJSON Errors where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } instance ToJSON Errors where toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } -- | Authorization Code Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.1.2.1 -- Implicit Grant Error Responses https://tools.ietf.org/html/rfc6749#section-4.2.2.1 data Errors = InvalidRequest | UnauthorizedClient | AccessDenied | UnsupportedResponseType | InvalidScope | ServerError | TemporarilyUnavailable deriving (Show, Eq, Generic) hoauth2-1.14.0/src/Network/OAuth/OAuth2/HttpClient.hs0000644000000000000000000003172307346545000020322 0ustar0000000000000000{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | A simple http client to request OAuth2 tokens and several utils. module Network.OAuth.OAuth2.HttpClient ( -- * Token management fetchAccessToken, fetchAccessToken2, refreshAccessToken, refreshAccessToken2, doSimplePostRequest, -- * AUTH requests authGetJSON, authGetBS, authGetBS2, authPostJSON, authPostBS, authPostBS2, authPostBS3, authRequest ) where import Data.Aeson import Data.Bifunctor (first) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.HashMap.Strict as HM (fromList) import Data.Maybe import qualified Data.Text.Encoding as T import Network.HTTP.Conduit import qualified Network.HTTP.Types as HT import Network.HTTP.Types.URI (parseQuery) import Network.OAuth.OAuth2.Internal import qualified Network.OAuth.OAuth2.TokenRequest as TR import URI.ByteString -------------------------------------------------- -- * Token management -------------------------------------------------- -- | Fetch OAuth2 Token with authenticate in request header. -- -- OAuth2 spec allows `client_id` and `client_secret` to -- either be sent in the header (as basic authentication) -- OR as form/url params. -- The OAuth server can choose to implement only one, or both. -- Unfortunately, there is no way for the OAuth client (i.e. this library) to -- know which method to use. Please take a look at the documentation of the -- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2` fetchAccessToken :: Manager -- ^ HTTP connection manager -> OAuth2 -- ^ OAuth Data -> ExchangeToken -- ^ OAuth2 Code -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token fetchAccessToken manager oa code = doJSONPostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code -- | Please read the docs of `fetchAccessToken`. -- fetchAccessToken2 :: Manager -- ^ HTTP connection manager -> OAuth2 -- ^ OAuth Data -> ExchangeToken -- ^ OAuth 2 Tokens -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token fetchAccessToken2 mgr oa code = do let (url, body1) = accessTokenUrl oa code let secret x = [("client_secret", T.encodeUtf8 x)] let extraBody = ("client_id", T.encodeUtf8 $ oauthClientId oa) : maybe [] secret (oauthClientSecret oa) doJSONPostRequest mgr oa url (extraBody ++ body1) -- | Fetch a new AccessToken with the Refresh Token with authentication in request header. -- OAuth2 spec allows `client_id` and `client_secret` to -- either be sent in the header (as basic authentication) -- OR as form/url params. -- The OAuth server can choose to implement only one, or both. -- Unfortunately, there is no way for the OAuth client (i.e. this library) to -- know which method to use. Please take a look at the documentation of the -- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2` refreshAccessToken :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth context -> RefreshToken -- ^ refresh token gained after authorization -> IO (OAuth2Result TR.Errors OAuth2Token) refreshAccessToken manager oa token = doJSONPostRequest manager oa uri body where (uri, body) = refreshAccessTokenUrl oa token -- | Please read the docs of `refreshAccessToken`. -- refreshAccessToken2 :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth context -> RefreshToken -- ^ refresh token gained after authorization -> IO (OAuth2Result TR.Errors 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 $ oauthClientId oa) : maybe [] secret (oauthClientSecret oa) doJSONPostRequest manager oa uri (extraBody ++ body) -- | Conduct post request and return response as JSON. doJSONPostRequest :: (FromJSON err, FromJSON a) => Manager -- ^ HTTP connection manager. -> 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) -- | 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 oauthClientSecret oa of (Just secret) -> applyBasicAuth (T.encodeUtf8 $ oauthClientId oa) (T.encodeUtf8 secret) Nothing -> id 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 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 -- | 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 [] -> Left errorMessage a -> case fromJSON $ queryToValue a of Error _ -> Left errorMessage Success x -> Right x where queryToValue = Object . HM.fromList . map paramToPair paramToPair (k, mv) = (T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv) errorMessage = parseOAuth2Error b -------------------------------------------------- -- * AUTH requests -------------------------------------------------- -- | Conduct an authorized GET request and return response as JSON. authGetJSON :: (FromJSON b) => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (Either BSL.ByteString b) -- ^ Response as JSON authGetJSON manager t uri = do resp <- authGetBS manager t uri return (resp >>= (first BSL.pack . eitherDecode)) -- | Conduct an authorized GET request. authGetBS :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (Either BSL.ByteString 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 authGetBS2 :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authGetBS2 manager token url = do req <- uriToRequest (url `appendAccessToken` token) authRequest req upReq manager where upReq = updateRequestHeaders Nothing . setMethod HT.GET -- | Conduct POST request and return response as JSON. authPostJSON :: (FromJSON b) => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (Either BSL.ByteString b) -- ^ Response as JSON authPostJSON manager t uri pb = do resp <- authPostBS manager t uri pb return (resp >>= (first BSL.pack . eitherDecode)) -- | Conduct POST request. authPostBS :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authPostBS manager token url pb = do req <- uriToRequest url authRequest req upReq manager where upBody = urlEncodedBody (pb ++ accessTokenToParam token) upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST upReq = upHeaders . upBody -- | Conduct POST request with access token in the request body rather header authPostBS2 :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authPostBS2 manager token url pb = do req <- uriToRequest url authRequest req upReq manager where upBody = urlEncodedBody (pb ++ accessTokenToParam token) upHeaders = updateRequestHeaders Nothing . setMethod HT.POST upReq = upHeaders . upBody -- | Conduct POST request with access token in the header and null in body authPostBS3 :: Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString authPostBS3 manager token url = do req <- uriToRequest url authRequest req upReq manager where upBody req = req { requestBody = "null" } upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST upReq = upHeaders . upBody -- |Send an HTTP request including the Authorization header with the specified -- access token. -- 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 -------------------------------------------------- -- * Utilities -------------------------------------------------- -- | Parses a @Response@ to to @OAuth2Result@ handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString handleResponse rsp = if HT.statusIsSuccessful (responseStatus rsp) then Right $ responseBody rsp else Left $ responseBody rsp -- | Set several header values: -- + userAgennt : `hoauth2` -- + accept : `application/json` -- + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided. updateRequestHeaders :: Maybe AccessToken -> Request -> Request updateRequestHeaders t req = let extras = [ (HT.hUserAgent, "hoauth2") , (HT.hAccept, "application/json") ] bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (atoken (fromJust t))) | isJust t] headers = bearer ++ extras ++ requestHeaders req in req { requestHeaders = headers } -- | Set the HTTP method to use. setMethod :: HT.StdMethod -> Request -> Request setMethod m req = req { method = HT.renderStdMethod m } hoauth2-1.14.0/src/Network/OAuth/OAuth2/Internal.hs0000644000000000000000000002130007346545000020006 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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 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 () -------------------------------------------------- -- * Data Types -------------------------------------------------- -- | Query Parameter Representation 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) -- | 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) instance Binary OAuth2Token parseIntFlexible :: Value -> Parser Int parseIntFlexible (String s) = pure . read $ unpack s 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" instance ToJSON OAuth2Token where 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) } deriving (Show, Eq, Generic) instance FromJSON err => FromJSON (OAuth2Error err) where parseJSON (Object a) = do err <- (a .: "error") >>= (\str -> Right <$> parseJSON str <|> Left <$> parseJSON str) desc <- a .:? "error_description" uri <- a .:? "error_uri" return $ OAuth2Error err desc uri 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 } parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err parseOAuth2Error string = either (mkDecodeOAuth2Error string) id (eitherDecode string) mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err mkDecodeOAuth2Error response err = OAuth2Error (Left "Decode error") (Just $ pack $ "Error: " <> err <> "\n Original Response:\n" <> show (decodeUtf8 $ BSL.toStrict response)) Nothing -------------------------------------------------- -- * 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)] 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) ] -- | 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 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' 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 ] -- | 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 oa token = (uri, body) 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 uri t = over (queryL . queryPairsL) (\query -> query ++ accessTokenToParam t) uri -- | Create 'QueryParams' with given access token value. accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)] accessTokenToParam t = [("access_token", encodeUtf8 $ atoken t)] appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a appendQueryParams params = over (queryL . queryPairsL) (params ++ ) uriToRequest :: MonadThrow m => URI -> m Request uriToRequest uri = do ssl <- case view (uriSchemeL . schemeBSL) uri of "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 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")) (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' } {-# INLINE hostLens #-} portLens :: Lens' Request Int portLens f req = f (C.port req) <&> \p' -> req { C.port = p' } {-# INLINE portLens #-} hoauth2-1.14.0/src/Network/OAuth/OAuth2/TokenRequest.hs0000644000000000000000000000124507346545000020671 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Network.OAuth.OAuth2.TokenRequest where import Data.Aeson import GHC.Generics instance FromJSON Errors where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } instance ToJSON Errors where toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } -- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2 data Errors = InvalidRequest | InvalidClient | InvalidGrant | UnauthorizedClient | UnsupportedGrantType | InvalidScope deriving (Show, Eq, Generic)