hoauth2-1.8.7/example/0000755000000000000000000000000013505157157012733 5ustar0000000000000000hoauth2-1.8.7/example/IDP/0000755000000000000000000000000013426102413013332 5ustar0000000000000000hoauth2-1.8.7/example/assets/0000755000000000000000000000000013365633115014232 5ustar0000000000000000hoauth2-1.8.7/example/templates/0000755000000000000000000000000013365633115014726 5ustar0000000000000000hoauth2-1.8.7/src/0000755000000000000000000000000013365633115012064 5ustar0000000000000000hoauth2-1.8.7/src/Network/0000755000000000000000000000000013365633115013515 5ustar0000000000000000hoauth2-1.8.7/src/Network/OAuth/0000755000000000000000000000000013365633115014535 5ustar0000000000000000hoauth2-1.8.7/src/Network/OAuth/OAuth2/0000755000000000000000000000000013371351731015635 5ustar0000000000000000hoauth2-1.8.7/src/Network/OAuth/OAuth2/HttpClient.hs0000644000000000000000000003063313365633115020256 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, fetchRefreshToken, refreshAccessToken, doJSONPostRequest, doFlexiblePostRequest, doSimplePostRequest, -- * AUTH requests authGetJSON, authGetBS, authGetBS2, authPostJSON, authPostBS, authPostBS2, authPostBS3, authRequest, -- * Utilities handleResponse, parseResponseJSON, parseResponseFlexible, updateRequestHeaders, setMethod ) where import Data.Aeson 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 -------------------------------------------------- -- | Request OAuth2 Token -- method: POST -- authenticate in header fetchAccessToken :: Manager -- ^ HTTP connection manager -> OAuth2 -- ^ OAuth Data -> ExchangeToken -- ^ OAuth 2 Tokens -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body where (uri, body) = accessTokenUrl oa code -- | Request OAuth2 Token -- method: POST -- authenticate in both header and body 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 extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId oa) , ("client_secret", T.encodeUtf8 $ oauthClientSecret oa) ] doFlexiblePostRequest mgr oa url (extraBody ++ body1) -- | Request a new AccessToken with the Refresh Token. refreshAccessToken :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth context -> RefreshToken -- ^ refresh token gained after authorization -> IO (OAuth2Result TR.Errors OAuth2Token) refreshAccessToken manager oa token = doFlexiblePostRequest manager oa uri body where (uri, body) = refreshAccessTokenUrl oa token {-# DEPRECATED fetchRefreshToken "Use refreshAccessToken since this method will be removed in future release" #-} fetchRefreshToken :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth context -> RefreshToken -- ^ refresh token gained after authorization -> IO (OAuth2Result TR.Errors OAuth2Token) fetchRefreshToken = refreshAccessToken -- | 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 parseResponseJSON (doSimplePostRequest manager oa uri body) -- | Conduct post request and return response as JSON or Query String. {-# DEPRECATED doFlexiblePostRequest "Use doJSONPostRequest since this function would be removed in future release." #-} doFlexiblePostRequest :: FromJSON err => FromJSON a => Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth options -> URI -- ^ The URL -> PostBody -- ^ request body -> IO (OAuth2Result err a) -- ^ Response as ByteString doFlexiblePostRequest 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 handleResponse go where go = do req <- uriToRequest url let addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauthClientId oa) (T.encodeUtf8 $ oauthClientSecret oa) req' = (addBasicAuth . updateRequestHeaders Nothing) req httpLbs (urlEncodedBody body req') manager -------------------------------------------------- -- * AUTH requests -------------------------------------------------- -- | Conduct an authorized GET request and return response as JSON. authGetJSON :: FromJSON err => FromJSON a => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (OAuth2Result err a) -- ^ Response as JSON authGetJSON manager t uri = parseResponseJSON <$> authGetBS manager t uri -- | Conduct an authorized GET request. authGetBS :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (OAuth2Result err 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 :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString authGetBS2 manager token url = do req <- uriToRequest (url `appendAccessToken` token) -- print $ queryString req authRequest req upReq manager where upReq = updateRequestHeaders Nothing . setMethod HT.GET -- | Conduct POST request and return response as JSON. authPostJSON :: FromJSON err => FromJSON a => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err a) -- ^ Response as JSON authPostJSON manager t uri pb = parseResponseJSON <$> authPostBS manager t uri pb -- | Conduct POST request. authPostBS :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err 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 :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err 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 :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (OAuth2Result err 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 :: FromJSON err => Request -- ^ Request to perform -> (Request -> Request) -- ^ Modify request before sending -> Manager -- ^ HTTP connection manager. -> IO (OAuth2Result err BSL.ByteString) authRequest req upReq manager = fmap handleResponse (httpLbs (upReq req) manager) -------------------------------------------------- -- * Utilities -------------------------------------------------- -- | Parses a @Response@ to to @OAuth2Result@ handleResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString handleResponse rsp = if HT.statusIsSuccessful (responseStatus rsp) then Right $ responseBody rsp else Left $ parseOAuth2Error (responseBody rsp) -- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@ 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 -- | 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 -- | 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 (fromJust (fmap atoken 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.8.7/src/Network/OAuth/OAuth2/Internal.hs0000644000000000000000000002107213371351731017747 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 (explicitParseFieldMaybe, Parser) 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 :: Text , oauthOAuthorizeEndpoint :: URI , oauthAccessTokenEndpoint :: URI , oauthCallback :: Maybe URI } deriving (Show, Eq) newtype AccessToken = AccessToken { atoken :: Text } deriving (Show, FromJSON, ToJSON) newtype RefreshToken = RefreshToken { rtoken :: Text } deriving (Show, FromJSON, ToJSON) newtype IdToken = IdToken { idtoken :: Text } deriving (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 (Show, Generic) 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 . maybe (const defaultPort) const . 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.8.7/src/Network/OAuth/OAuth2.hs0000644000000000000000000000124113365633115016171 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.8.7/src/Network/OAuth/OAuth2/TokenRequest.hs0000644000000000000000000000124513365633115020626 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) hoauth2-1.8.7/src/Network/OAuth/OAuth2/AuthorizationRequest.hs0000644000000000000000000000146613365633115022413 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.8.7/example/main.hs0000644000000000000000000000011013365633115014200 0ustar0000000000000000module Main where import App (app) main :: IO () main = app hoauth2-1.8.7/example/IDP.hs0000644000000000000000000000267513367130346013712 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 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 ] 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 (idpLabel idp) hoauth2-1.8.7/example/App.hs0000644000000000000000000001115513426101402013772 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module App (app, waiApp) where import Control.Monad import Control.Monad.Error.Class import Control.Monad.IO.Class (liftIO) import Data.Bifunctor import Data.Maybe import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL 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 Web.Scotty import Web.Scotty.Internal.Types import IDP import Session import Types import Utils import Views ------------------------------ -- 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 debug :: Bool debug = True -------------------------------------------------- -- * Handlers -------------------------------------------------- redirectToHomeM :: ActionM () redirectToHomeM = redirect "/" errorM :: Text -> ActionM () errorM = throwError . ActionError globalErrorHandler :: Text -> ActionM () globalErrorHandler t = status status401 >> html t logoutH :: CacheStore -> ActionM () logoutH c = do pas <- params let idpP = paramValue "idp" pas when (null idpP) redirectToHomeM let eitherIdpApp = parseIDP (head idpP) case eitherIdpApp of Right (IDPApp idp) -> liftIO (removeKey c (idpLabel idp)) >> redirectToHomeM Left e -> errorM ("logout: unknown IDP " `TL.append` e) 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) (errorM "callbackH: no code from callback request") when (null stateP) (errorM "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 -> errorM ("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) (errorM "fetchTokenAndUser: cannot find idp data from cache") let idpData = fromJust maybeIdpData result <- liftIO $ tryFetchUser idp code case result of Right luser -> updateIdp c idpData luser >> redirectToHomeM Left err -> errorM ("fetchTokenAndUser: " `TL.append` err) where lookIdp c1 idp1 = liftIO $ lookupKey c1 (idpLabel idp1) updateIdp c1 oldIdpData luser = liftIO $ insertIDPData c1 (oldIdpData {loginUser = Just luser }) -- TODO: may use Exception monad to capture error in this IO monad -- tryFetchUser :: (HasTokenReq a, HasUserReq a, HasLabel a) => a -> TL.Text -- ^ code -> IO (Either Text LoginUser) tryFetchUser idp code = do mgr <- newManager tlsManagerSettings token <- tokenReq idp mgr (ExchangeToken $ TL.toStrict code) when debug (print token) case token of Right at -> fetchUser idp mgr (accessToken at) Left e -> return (Left $ TL.pack $ "tryFetchUser: cannot fetch asses token. error detail: " ++ show 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 displayOAuth2Error re) displayOAuth2Error :: OAuth2Error Errors -> Text displayOAuth2Error = TL.pack . show hoauth2-1.8.7/example/IDP/AzureAD.hs0000644000000000000000000000255313367130346015200 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 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.8.7/example/IDP/Douban.hs0000644000000000000000000000257513365633115015121 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 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.8.7/example/IDP/Dropbox.hs0000644000000000000000000000326013365633115015316 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module IDP.Dropbox 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 Dropbox = Dropbox deriving (Show, Generic) instance Hashable Dropbox instance IDP Dropbox instance HasLabel Dropbox instance HasTokenReq Dropbox where tokenReq _ mgr = fetchAccessToken mgr dropboxKey instance HasUserReq Dropbox where userReq _ mgr at = do re <- parseResponseJSON <$> authPostBS3 mgr at userInfoUri return (second toLoginUser re) 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.8.7/example/IDP/Facebook.hs0000644000000000000000000000306213365633115015412 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 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.8.7/example/IDP/Fitbit.hs0000644000000000000000000000313713365633115015125 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 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.8.7/example/IDP/Github.hs0000644000000000000000000000251513365633115015125 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 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.8.7/example/IDP/Google.hs0000644000000000000000000000275313365633115015123 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 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.8.7/example/IDP/Okta.hs0000644000000000000000000000270713365633115014604 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 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") ] 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.8.7/example/IDP/StackExchange.hs0000644000000000000000000000527613426102413016410 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 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 HasUserReq StackExchange where userReq _ mgr token = do re <- parseResponseJSON <$> authGetBS2 mgr token (userInfoUri `appendStackExchangeAppKey` stackexchangeAppKey) return (second toLoginUser re) 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.8.7/example/IDP/Weibo.hs0000644000000000000000000000346513365633115014755 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module IDP.Weibo where import Data.Aeson import Data.Bifunctor 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 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 <- parseResponseJSON <$> authGetBS2 mgr at userInfoUri return (second toLoginUser re) 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.8.7/example/IDP/Linkedin.hs0000644000000000000000000000256713365633115015447 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.8.7/example/Keys.hs0000644000000000000000000001164013505157153014200 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 = "1962132691" , oauthClientSecret = "a2ad30383bdff9bcb12be6a3d30deeb1" , oauthCallback = Just [uri|http://127.0.0.1:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://api.weibo.com/oauth2/authorize|] , oauthAccessTokenEndpoint = [uri|https://api.weibo.com/oauth2/access_token|] } -- | http://developer.github.com/v3/oauth/ githubKey :: OAuth2 githubKey = OAuth2 { oauthClientId = "bf86d338485a96a93c88" , oauthClientSecret = "a1c00dada665dc00aa6fafe0495c7c885f82d1ce" , oauthCallback = Just [uri|http://127.0.0.1:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://github.com/login/oauth/authorize|] , oauthAccessTokenEndpoint = [uri|https://github.com/login/oauth/access_token|] } -- | oauthCallback = Just "https://developers.google.com/oauthplayground" googleKey :: OAuth2 googleKey = OAuth2 { oauthClientId = "886894027376.apps.googleusercontent.com" , oauthClientSecret = "27w98gwGB1h8N5a6JQ2bT_nm" , oauthCallback = Just [uri|http://127.0.0.1:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://accounts.google.com/o/oauth2/auth|] , oauthAccessTokenEndpoint = [uri|https://www.googleapis.com/oauth2/v3/token|] } facebookKey :: OAuth2 facebookKey = OAuth2 { oauthClientId = "414630782030965" , oauthClientSecret = "0e648eae100da4d03f16594f231fc1d0" , oauthCallback = Just [uri|http://127.0.0.1:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|] , oauthAccessTokenEndpoint = [uri|https://graph.facebook.com/v2.3/oauth/access_token|] } doubanKey :: OAuth2 doubanKey = OAuth2 { oauthClientId = "02a914cf299ca31607fb3e6d7cd5e942" , oauthClientSecret = "3c0fdef13b0dd271" , 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 = "229LN9" , oauthClientSecret = "2f4aa9a275c2d4bb9eb616efbd2c1311" , 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 = "7185" , oauthClientSecret = "K5hK)ET*dbFGFmNFVtqIyA((" , 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 = "zbyxxox19gz6dgg" , oauthClientSecret = "ihhui0ysp85oi8s" , 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 = "0oad3popatwUIhWV40h7" , oauthClientSecret = "YFqXRjtsy7IYRbueiG2tcgHzhaawLccxqq5ruPfN" , 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 = "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|] } hoauth2-1.8.7/example/Session.hs0000644000000000000000000000171313365633115014711 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 $ maybe Nothing (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.8.7/example/Types.hs0000644000000000000000000000560413365633115014375 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Types where import Control.Concurrent.MVar import Data.Aeson 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) => HasUserReq a where userReq :: FromJSON b => a -> Manager -> AccessToken -> IO (OAuth2Result b LoginUser) -- Heterogenous collections -- https://wiki.haskell.org/Heterogenous_collections -- data IDPApp = forall a. (IDP a, HasTokenReq a, HasUserReq a, HasLabel a, HasAuthUri a) => IDPApp a -- 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 , 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.8.7/example/Utils.hs0000644000000000000000000000175713365633115014376 0ustar0000000000000000module Utils where import qualified Data.Aeson as Aeson import Data.ByteString (ByteString) 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 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.8.7/example/Views.hs0000644000000000000000000000174413365633115014367 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.8.7/LICENSE0000644000000000000000000000276413365633115012313 0ustar0000000000000000Copyright (c)2012-2017, 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.8.7/Setup.hs0000644000000000000000000000005613365633115012732 0ustar0000000000000000import Distribution.Simple main = defaultMain hoauth2-1.8.7/hoauth2.cabal0000644000000000000000000001315313505156242013633 0ustar0000000000000000Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy Version: 1.8.7 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: BSD3 License-file: LICENSE Author: Haisheng Wu Maintainer: Haisheng Wu Copyright: Haisheng Wu Category: Network Build-type: Simple stability: Beta tested-with: GHC <= 8.0.2 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 Cabal-version: >=1.10 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, text >= 0.11 && < 1.3, bytestring >= 0.9 && < 0.11, http-conduit >= 2.1 && < 2.4, http-types >= 0.11 && < 0.13, aeson >= 1.0.0.0 && < 1.5, 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 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 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 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.0.0.0 && < 1.5, microlens >= 0.4.0 && < 0.5, unordered-containers >= 0.2.5, wai-extra >= 3.0.21.0 && < 3.0.27.0, wai-middleware-static >= 0.8.1 && < 0.8.3, mustache >= 2.2.3 && < 2.4.0, mtl >= 2.2.1 && < 2.3, scotty >= 0.10.0 && < 0.12, binary >= 0.8.3.0 && < 0.8.7, parsec >= 3.1.11 && < 3.2.0 , hashable >= 1.2.6 && < 1.4.0, hoauth2 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields hoauth2-1.8.7/README.md0000644000000000000000000000111513365633115012552 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 # Contribute Feel free send pull request or submit issue ticket. hoauth2-1.8.7/example/Keys.hs.sample0000644000000000000000000001141713367130346015463 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 = "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 = "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 = "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 = "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 = "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 = "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 = "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 = "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 = "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 = "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|] } hoauth2-1.8.7/example/README.md0000644000000000000000000000132413367130346014207 0ustar0000000000000000 * IDPs - AzureAD: - douban: - Google: - Github: - Facebook: - Fitbit: - StackExchange: - StackExchange Apps page: - DropBox: - Weibo: * WIP: Linkedin - hoauth2-1.8.7/example/templates/index.mustache0000644000000000000000000000136013365633115017570 0ustar0000000000000000

Hello OAuth2

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

Notes

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

hoauth2-1.8.7/example/assets/main.css0000644000000000000000000000023713365633115015672 0ustar0000000000000000body { padding: 10px 50px; } .login-with { margin: 10px 0; padding: 10px; border: 1px solid grey; border-radius: 5px; width: 500px; }