diff --git a/example/App.hs b/example/App.hs new file mode 100644 --- /dev/null +++ b/example/App.hs @@ -0,0 +1,142 @@ +{-# 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 + diff --git a/example/Douban/test.hs b/example/Douban/test.hs deleted file mode 100644 --- a/example/Douban/test.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- - -douban oauth2: http://developers.douban.com/wiki/?title=oauth2 - -/v2/movie/nowplaying - --} - -module Main where - -import qualified Data.ByteString.Char8 as BS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy.Encoding as TL -import Network.HTTP.Conduit -import URI.ByteString -import URI.ByteString.QQ - -import Network.OAuth.OAuth2 - -import Keys (doubanKey) - -import Data.Aeson -import Data.Aeson.Types -import GHC.Generics - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - -main :: IO () -main = do - BS.putStrLn $ serializeURIRef' $ authorizationUrl doubanKey - putStrLn "visit the url and paste code here: " - code <- fmap (ExchangeToken . T.pack) getLine - mgr <- newManager tlsManagerSettings - let (url, body) = accessTokenUrl doubanKey code - let extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId doubanKey) - , ("client_secret", T.encodeUtf8 $ oauthClientSecret doubanKey) - ] - - token :: OAuth2Result Errors OAuth2Token <- doJSONPostRequest mgr doubanKey url (extraBody ++ body) - print token - case token of - Right r -> do - -- TODO: display Chinese character. (Text UTF-8 encodeing does not work, why?) - uid <- authGetBS mgr (accessToken r) [uri|https://api.douban.com/v2/user/~me|] - putStrLn $ either (show :: OAuth2Error Errors -> String) (show . TL.decodeUtf8) uid - Left l -> print l - -sToBS :: String -> BS.ByteString -sToBS = T.encodeUtf8 . T.pack diff --git a/example/Dropbox/test.hs b/example/Dropbox/test.hs deleted file mode 100644 --- a/example/Dropbox/test.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Text as T -import GHC.Generics -import Network.HTTP.Conduit -import qualified Network.HTTP.Types as HT -import URI.ByteString - -import Network.OAuth.OAuth2 - -import Keys - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - -main :: IO () -main = do - BS.putStrLn $ serializeURIRef' $ authorizationUrl dropboxKey - putStrLn "visit the url and paste code here: " - code <- getLine - mgr <- newManager tlsManagerSettings - token <- fetchAccessToken mgr dropboxKey (ExchangeToken (T.pack code)) - print token - case token of - Right at -> getSpaceUsage mgr (accessToken at) >>= print - Left _ -> putStrLn "no access token found yet" - -getSpaceUsage :: Manager -> AccessToken -> IO (OAuth2Result Errors BSL.ByteString) -getSpaceUsage mgr token = do - req <- parseRequest $ BS.unpack "https://api.dropboxapi.com/2/users/get_space_usage" - authRequest req upReq mgr - where upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST - upBody req = req {requestBody = "null" } - upReq = upHeaders . upBody diff --git a/example/Facebook/test.hs b/example/Facebook/test.hs deleted file mode 100644 --- a/example/Facebook/test.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -{- Facebook example -} - -module Main where - -import Keys (facebookKey) -import Network.OAuth.OAuth2 - -import Data.Aeson.TH (defaultOptions, deriveJSON) -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.HTTP.Conduit -import URI.ByteString -import URI.ByteString.QQ - -import Data.Aeson -import Data.Aeson.Types -import GHC.Generics - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - - --------------------------------------------------- - -data User = User { id :: Text - , name :: Text - , email :: Text - } deriving (Show) - -$(deriveJSON defaultOptions ''User) - --------------------------------------------------- - -main :: IO () -main = do - print $ serializeURIRef' $ appendQueryParams facebookScope $ authorizationUrl facebookKey - putStrLn "visit the url and paste code here: " - code <- getLine - mgr <- newManager tlsManagerSettings - let (url, body) = accessTokenUrl facebookKey $ ExchangeToken $ T.pack code - let extraBody = [ ("state", "test") - , ("client_id", T.encodeUtf8 $ oauthClientId facebookKey) - , ("client_secret", T.encodeUtf8 $ oauthClientSecret facebookKey) - ] - resp <- doJSONPostRequest mgr facebookKey url (body ++ extraBody) - case (resp :: OAuth2Result Errors OAuth2Token) of - Right token -> do - print token - userinfo mgr (accessToken token) >>= print - userinfo' mgr (accessToken token) >>= print - Left l -> print l - --------------------------------------------------- --- FaceBook API - --- | Gain read-only access to the user's id, name and email address. -facebookScope :: QueryParams -facebookScope = [("scope", "user_about_me,email")] - --- | Fetch user id and email. -userinfo :: Manager -> AccessToken -> IO (OAuth2Result Errors BL.ByteString) -userinfo mgr token = authGetBS mgr token [uri|https://graph.facebook.com/me?fields=id,name,email|] - -userinfo' :: FromJSON User => Manager -> AccessToken -> IO (OAuth2Result Errors User) -userinfo' mgr token = authGetJSON mgr token [uri|https://graph.facebook.com/me?fields=id,name,email|] diff --git a/example/Fitbit/test.hs b/example/Fitbit/test.hs deleted file mode 100644 --- a/example/Fitbit/test.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main where - -import Control.Monad (mzero) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Char (chr) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.HTTP.Conduit hiding (Request, queryString) -import Network.HTTP.Types (Query, status200) -import Network.Wai -import Network.Wai.Handler.Warp (run) -import URI.ByteString (serializeURIRef') -import URI.ByteString.QQ - -import Keys (fitbitKey) -import Network.OAuth.OAuth2 - -import Data.Aeson -import Data.Aeson.Types -import GHC.Generics - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - - ------------------------------------------------------------------------------- - -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 - -instance ToJSON FitbitUser where - toJSON (FitbitUser fid name age) = - object [ "id" .= fid - , "name" .= name - , "age" .= age - ] - ------------------------------------------------------------------------------- - -main :: IO () -main = do - print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey - putStrLn "visit the url to continue" - run 9988 application - -state :: B.ByteString -state = "testFitbitApi" - -application :: Application -application request respond = do - response <- handleRequest requestPath request - respond $ responseLBS status200 [("Content-Type", "text/plain")] response - where - requestPath = T.intercalate "/" $ pathInfo request - -handleRequest :: Text -> Request -> IO BL.ByteString -handleRequest "favicon.ico" _ = return "" -handleRequest _ request = do - mgr <- newManager tlsManagerSettings - token <- getApiToken mgr $ getApiCode request - print token - user <- getApiUser mgr (accessToken token) - print user - return $ encode user - -getApiCode :: Request -> ExchangeToken -getApiCode request = - case M.lookup "code" queryMap of - Just code -> ExchangeToken $ T.decodeUtf8 code - Nothing -> Prelude.error "request doesn't include code" - where - queryMap = convertQueryToMap $ queryString request - -getApiToken :: Manager -> ExchangeToken -> IO OAuth2Token -getApiToken mgr code = do - result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)] - case result of - Right token -> return token - Left (e :: OAuth2Error Errors) -> Prelude.error $ show e - where - (url, body) = accessTokenUrl fitbitKey code - -getApiUser :: Manager -> AccessToken -> IO FitbitUser -getApiUser mgr token = do - result <- authGetJSON mgr token [uri|https://api.fitbit.com/1/user/-/profile.json|] - case result of - Right user -> return user - Left (e :: OAuth2Error Errors) -> Prelude.error $ show e - -convertQueryToMap :: Query -> M.Map B.ByteString B.ByteString -convertQueryToMap query = - M.fromList $ map normalize query - where - normalize (k, Just v) = (k, v) - normalize (k, Nothing) = (k, B.empty) - -lazyBSToString :: BL.ByteString -> String -lazyBSToString s = map (chr . fromIntegral) (BL.unpack s) diff --git a/example/Github/test.hs b/example/Github/test.hs deleted file mode 100644 --- a/example/Github/test.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - --- | Github API: http://developer.github.com/v3/oauth/ - -module Main where - -import Control.Monad (mzero) -import qualified Data.ByteString as BS -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.HTTP.Conduit -import URI.ByteString -import URI.ByteString.QQ - -import Network.OAuth.OAuth2 -import qualified Network.OAuth.OAuth2.AuthorizationRequest as AR - -import Keys - -import Data.Aeson -import Data.Aeson.Types -import GHC.Generics - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - - - -main :: IO () -main = do - let state = "testGithubApi" - mgr <- newManager tlsManagerSettings - putStrLn "Trying invalid token..." - failToken <- getToken state "invalidCode" mgr - print (failToken :: OAuth2Result AR.Errors OAuth2Token) - print $ serializeURIRef' $ appendQueryParams [("state", state)] $ authorizationUrl githubKey - putStrLn "visit the url and paste code here: " - code <- getLine - token <- getToken state code mgr - print (token :: OAuth2Result AR.Errors OAuth2Token) - case token of - Right at -> userInfo mgr (accessToken at) >>= print - Left _ -> putStrLn "no access token found yet" - -getToken :: FromJSON a => BS.ByteString -> String -> Manager -> IO (OAuth2Result AR.Errors a) -getToken state code mgr = do - let (url, body) = accessTokenUrl githubKey $ ExchangeToken $ T.pack code - doJSONPostRequest mgr githubKey url (body ++ [("state", state)]) - --- | Test API: user --- -userInfo :: Manager -> AccessToken -> IO (OAuth2Result (OAuth2Error Errors) GithubUser) -userInfo mgr token = authGetJSON mgr token [uri|https://api.github.com/user|] - -data GithubUser = GithubUser { gid :: Integer - , gname :: Text - } deriving (Show, Eq) - -instance FromJSON GithubUser where - parseJSON (Object o) = GithubUser - <$> o .: "id" - <*> o .: "name" - parseJSON _ = mzero - -sToBS :: String -> BS.ByteString -sToBS = T.encodeUtf8 . T.pack diff --git a/example/Google/test.hs b/example/Google/test.hs deleted file mode 100644 --- a/example/Google/test.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -{- - -This is basically very manual test. Check following link for details. - -Google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer - -Google OAuth 2.0 playround: https://developers.google.com/oauthplayground/ - --} - -module Main where - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Internal as BL -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics -import Network.HTTP.Conduit -import System.Environment (getArgs) -import URI.ByteString -import URI.ByteString.QQ - -import Keys (googleKey) -import Network.OAuth.OAuth2 - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - --------------------------------------------------- - -data Token = Token { issuedTo :: Text - , audience :: Text - , userId :: Maybe Text - , scope :: Text - , expiresIn :: Integer - , accessType :: Text - } deriving (Show, Generic) - - -data User = User { id :: Text - , name :: Text - , givenName :: Text - , familyName :: Text - , link :: Text - , picture :: Text - , gender :: Text - , locale :: Text - } deriving (Show, Generic) - -instance FromJSON Token where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } - -instance ToJSON Token where - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } - -instance FromJSON User where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } - -instance ToJSON User where - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } - --------------------------------------------------- - -main :: IO () -main = do - xs <- getArgs - mgr <- newManager tlsManagerSettings - case xs of - ["offline"] -> offlineCase mgr - _ -> normalCase mgr - -offlineCase :: Manager -> IO () -offlineCase mgr = do - BS.putStrLn $ serializeURIRef' $ appendQueryParams (googleScopeEmail ++ googleAccessOffline) $ authorizationUrl googleKey - putStrLn "offline mode: visit the url and paste code here: " - code <- getLine - (Right token) <- fetchAccessToken mgr googleKey $ ExchangeToken $ T.pack code - f (accessToken token) - -- - -- obtain a new access token with refresh token, which turns out only in response at first time. - -- Revoke Access https://www.google.com/settings/security - -- - case refreshToken token of - Nothing -> putStrLn "Failed to fetch refresh token" - Just tk -> do - (Right token') <- fetchRefreshToken mgr googleKey tk - f (accessToken token') - --validateToken accessToken >>= print - --(validateToken' accessToken :: IO (OAuth2Result Token)) >>= print - where f token = do - print token - validateToken mgr token >>= print - (validateToken' mgr token :: IO (OAuth2Result (OAuth2Error Errors) Token)) >>= print - -normalCase :: Manager -> IO () -normalCase mgr = do - -- try an invalid token - putStr "Trying invalid token..." - validateToken mgr (AccessToken "invalid") >>= print - BS.putStrLn $ serializeURIRef' $ appendQueryParams googleScopeUserInfo (authorizationUrl googleKey) - putStrLn "normal mode: visit the url and paste code here: " - code <- fmap (ExchangeToken . T.pack) getLine - maybeToken <- fetchAccessToken mgr googleKey code - print maybeToken - (Right token) <- return maybeToken - putStr "AccessToken: " >> print token - -- get response in ByteString - validateToken mgr (accessToken token) >>= print - -- get response in JSON - (validateToken' mgr (accessToken token):: IO (OAuth2Result (OAuth2Error Errors) Token)) >>= print - -- get response in ByteString - userinfo mgr (accessToken token) >>= print - -- get response in JSON - (userinfo' mgr (accessToken token) :: IO (OAuth2Result (OAuth2Error Errors) User)) >>= print - --------------------------------------------------- --- Google API - --- | This is special for google Gain read-only access to the user's email address. -googleScopeEmail :: QueryParams -googleScopeEmail = [("scope", "https://www.googleapis.com/auth/userinfo.email")] - --- | Gain read-only access to basic profile information, including a -googleScopeUserInfo :: QueryParams -googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")] - --- | Access offline -googleAccessOffline :: QueryParams -googleAccessOffline = [("access_type", "offline") - ,("approval_prompt", "force")] - --- | Token Validation -validateToken :: Manager - -> AccessToken - -> IO (OAuth2Result (OAuth2Error Errors) BL.ByteString) -validateToken mgr token = - authGetBS' mgr token url - where url = [uri|https://www.googleapis.com/oauth2/v1/tokeninfo|] - -validateToken' :: FromJSON a - => Manager - -> AccessToken - -> IO (OAuth2Result (OAuth2Error Errors) a) -validateToken' mgr token = parseResponseJSON <$> validateToken mgr token - --- | fetch user email. --- for more information, please check the playround site. --- -userinfo :: Manager - -> AccessToken - -> IO (OAuth2Result (OAuth2Error Errors) BL.ByteString) -userinfo mgr token = authGetBS mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|] - -userinfo' :: FromJSON a - => Manager - -> AccessToken - -> IO (OAuth2Result (OAuth2Error Errors) a) -userinfo' mgr token = authGetJSON mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|] diff --git a/example/IDP.hs b/example/IDP.hs new file mode 100644 --- /dev/null +++ b/example/IDP.hs @@ -0,0 +1,43 @@ + +module IDP where + +import Data.Text.Lazy (Text) + +import qualified Data.HashMap.Strict as Map +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 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) diff --git a/example/IDP/Douban.hs b/example/IDP/Douban.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Douban.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module IDP.Douban where +import Data.Aeson +import Data.Aeson.Types +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 } + diff --git a/example/IDP/Dropbox.hs b/example/IDP/Dropbox.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Dropbox.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module IDP.Dropbox where +import Data.Aeson +import Data.Aeson.Types +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 } diff --git a/example/IDP/Facebook.hs b/example/IDP/Facebook.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Facebook.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module IDP.Facebook where +import Data.Aeson +import Data.Aeson.Types +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 } diff --git a/example/IDP/Fitbit.hs b/example/IDP/Fitbit.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Fitbit.hs @@ -0,0 +1,60 @@ +{-# 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 } diff --git a/example/IDP/Github.hs b/example/IDP/Github.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Github.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module IDP.Github where +import Data.Aeson +import Data.Aeson.Types +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 } diff --git a/example/IDP/Google.hs b/example/IDP/Google.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Google.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module IDP.Google where +import Data.Aeson +import Data.Aeson.Types +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 } + diff --git a/example/IDP/Linkedin.hs b/example/IDP/Linkedin.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Linkedin.hs @@ -0,0 +1,46 @@ +{-# 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 + } +-} diff --git a/example/IDP/Okta.hs b/example/IDP/Okta.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Okta.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module IDP.Okta where +import Data.Aeson +import Data.Aeson.Types +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 } + diff --git a/example/IDP/StackExchange.hs b/example/IDP/StackExchange.hs new file mode 100644 --- /dev/null +++ b/example/IDP/StackExchange.hs @@ -0,0 +1,76 @@ +{-# 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.Aeson.Types +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 + diff --git a/example/IDP/Weibo.hs b/example/IDP/Weibo.hs new file mode 100644 --- /dev/null +++ b/example/IDP/Weibo.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module IDP.Weibo where +import Data.Aeson +import Data.Aeson.Types +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 } diff --git a/example/Keys.hs b/example/Keys.hs --- a/example/Keys.hs +++ b/example/Keys.hs @@ -3,13 +3,14 @@ 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/oauthCallback|] + , 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|] } @@ -18,7 +19,7 @@ githubKey :: OAuth2 githubKey = OAuth2 { oauthClientId = "bf86d338485a96a93c88" , oauthClientSecret = "a1c00dada665dc00aa6fafe0495c7c885f82d1ce" - , oauthCallback = Just [uri|http://127.0.0.1:9988/githubCallback|] + , 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|] } @@ -27,7 +28,7 @@ googleKey :: OAuth2 googleKey = OAuth2 { oauthClientId = "886894027376.apps.googleusercontent.com" , oauthClientSecret = "27w98gwGB1h8N5a6JQ2bT_nm" - , oauthCallback = Just [uri|http://127.0.0.1:9988/googleCallback|] + , 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|] } @@ -49,15 +50,15 @@ facebookKey :: OAuth2 facebookKey = OAuth2 { oauthClientId = "414630782030965" , oauthClientSecret = "0e648eae100da4d03f16594f231fc1d0" - , oauthCallback = Just [uri|http://t.haskellcn.org/cb|] + , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://www.facebook.com/dialog/oauth|] - , oauthAccessTokenEndpoint = [uri|https://graph.facebook.com/v2.3/oauth/access_token|] + , oauthAccessTokenEndpoint = [uri|https://graph.facebook.com/v2.12/oauth/access_token|] } doubanKey :: OAuth2 doubanKey = OAuth2 { oauthClientId = "02a914cf299ca31607fb3e6d7cd5e942" , oauthClientSecret = "3c0fdef13b0dd271" - , oauthCallback = Just [uri|http://localhost:9999/oauthCallback|] + , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://www.douban.com/service/auth2/auth|] , oauthAccessTokenEndpoint = [uri|https://www.douban.com/service/auth2/token|] } @@ -70,12 +71,15 @@ , oauthAccessTokenEndpoint = [uri|https://api.fitbit.com/oauth2/token|] } +stackexchangeAppKey :: ByteString +stackexchangeAppKey = "LZvAveRFYw8lgNluEU2pDQ((" + stackexchangeKey :: OAuth2 stackexchangeKey = OAuth2 { oauthClientId = "7185" , oauthClientSecret = "K5hK)ET*dbFGFmNFVtqIyA((" - , oauthCallback = Just [uri|http://c.haskellcn.org/cb|] + , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] , oauthOAuthorizeEndpoint = [uri|https://stackexchange.com/oauth|] - , oauthAccessTokenEndpoint = [uri|https://stackexchange.com/oauth/access_token|] + , oauthAccessTokenEndpoint = [uri|https://stackexchange.com/oauth/access_token/json|] } dropboxKey :: OAuth2 @@ -93,3 +97,12 @@ , oauthOAuthorizeEndpoint = [uri|https://dev-148986.oktapreview.com/oauth2/v1/authorize|] , oauthAccessTokenEndpoint = [uri|https://dev-148986.oktapreview.com/oauth2/v1/token|] } + +linkedinKey :: OAuth2 +linkedinKey = OAuth2 { oauthClientId = "86r7dx3b0piy56" + , oauthClientSecret = "lBb5kA5lpggHT0Ne" + , oauthCallback = Just [uri|http://localhost:9988/oauth2/callback|] + , oauthOAuthorizeEndpoint = [uri|https://www.linkedin.com/oauth/v2/authorization|] + , oauthAccessTokenEndpoint = [uri|https://www.linkedin.com/oauth/v2/accessToken|] + } + diff --git a/example/Keys.hs.sample b/example/Keys.hs.sample --- a/example/Keys.hs.sample +++ b/example/Keys.hs.sample @@ -3,6 +3,7 @@ module Keys where +import Data.ByteString (ByteString) import Network.OAuth.OAuth2 import URI.ByteString.QQ @@ -55,6 +56,11 @@ , 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" diff --git a/example/Okta/test.hs b/example/Okta/test.hs deleted file mode 100644 --- a/example/Okta/test.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module Main where - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Text as T -import GHC.Generics -import Network.HTTP.Conduit -import qualified Network.HTTP.Types as HT -import URI.ByteString -import URI.ByteString.QQ - -import Network.OAuth.OAuth2 - -import Keys - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - -main :: IO () -main = do - BS.putStrLn - $ serializeURIRef' - $ appendQueryParams [("scope", "openid profile"), ("state", "test-state-123")] - $ authorizationUrl oktaKey - putStrLn "visit the url and paste code here: " - code <- getLine - mgr <- newManager tlsManagerSettings - token <- fetchAccessToken mgr oktaKey (ExchangeToken (T.pack code)) - print token - case token of - Right at -> getUserInfo mgr (accessToken at) >>= print - Left _ -> putStrLn "no access token found yet" - -getUserInfo :: Manager -> AccessToken -> IO (OAuth2Result Errors BSL.ByteString) -getUserInfo mgr token = - authGetBS mgr token [uri|https://dev-148986.oktapreview.com/oauth2/v1/userinfo|] diff --git a/example/README.md b/example/README.md new file mode 100644 --- /dev/null +++ b/example/README.md @@ -0,0 +1,13 @@ +* IDPs + - douban: http://developers.douban.com/wiki/?title=oauth2 + - Google: + - Github: + - Facebook: + - Fitbit: + - StackExchange: + - StackExchange Apps page: + - DropBox: + - Weibo: + +** Linkedin + - diff --git a/example/Session.hs b/example/Session.hs new file mode 100644 --- /dev/null +++ b/example/Session.hs @@ -0,0 +1,38 @@ +{-# 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 diff --git a/example/StackExchange/test.hs b/example/StackExchange/test.hs deleted file mode 100644 --- a/example/StackExchange/test.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | https://api.stackexchange.com/docs/authentication - -module Main where - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString.Char8 as BS -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import GHC.Generics -import Network.HTTP.Conduit -import URI.ByteString -import URI.ByteString.QQ - -import Keys (stackexchangeKey) -import Network.OAuth.OAuth2 - -data SiteInfo = SiteInfo { items :: [SiteItem] - , hasMore :: Bool - , quotaMax :: Integer - , quotaRemaining :: Integer - } deriving (Show, Eq, Generic) - -data SiteItem = SiteItem { newActiveUsers :: Integer - , totalUsers :: Integer - , badgesPerMinute :: Double - , totalBadges :: Integer - , totalVotes :: Integer - , totalComments :: Integer - , answersPerMinute :: Double - , questionsPerMinute :: Double - , totalAnswers :: Integer - , totalAccepted :: Integer - , totalUnanswered :: Integer - , totalQuestions :: Integer - , apiRevision :: Text - } deriving (Show, Eq, Generic) - -instance FromJSON SiteInfo where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } - -instance ToJSON SiteInfo where - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } - -instance FromJSON SiteItem where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } - -instance ToJSON SiteItem where - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' } - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - - - -main :: IO () -main = do - BS.putStrLn $ serializeURIRef' $ authorizationUrl stackexchangeKey - putStrLn "visit the url and paste code here: " - code <- fmap (ExchangeToken . T.pack) getLine - mgr <- newManager tlsManagerSettings - let (url, body) = accessTokenUrl stackexchangeKey code - let extraBody = [ ("state", "test") - , ("client_id", T.encodeUtf8 $ oauthClientId stackexchangeKey) - , ("client_secret", T.encodeUtf8 $ oauthClientSecret stackexchangeKey) - ] - - -- NOTE: stackexchange doesn't really comply with standard, its access token response looks like - -- `access_token=...&expires=1234`. - -- the `doFlexiblePostRequest` is able to convert it to OAuth2Token type - -- but the `expires` is lost given standard naming is `expires_in` - token <- doFlexiblePostRequest mgr stackexchangeKey url (extraBody ++ body) - print token - case token of - Right at -> siteInfo mgr (accessToken at) >>= print - Left (_ :: OAuth2Error Errors) -> putStrLn "no access token found yet" - --- | Test API: info -siteInfo :: Manager -> AccessToken -> IO (OAuth2Result (OAuth2Error Errors) SiteInfo) -siteInfo mgr token = authGetJSON mgr token [uri|https://api.stackexchange.com/2.2/info?site=stackoverflow|] - -sToBS :: String -> BS.ByteString -sToBS = T.encodeUtf8 . T.pack diff --git a/example/Types.hs b/example/Types.hs new file mode 100644 --- /dev/null +++ b/example/Types.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +module Types where + +import Control.Concurrent.MVar +import Data.Aeson +import Data.Aeson.Types +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) + +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' + ] diff --git a/example/Utils.hs b/example/Utils.hs new file mode 100644 --- /dev/null +++ b/example/Utils.hs @@ -0,0 +1,34 @@ +module 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 + + diff --git a/example/Views.hs b/example/Views.hs new file mode 100644 --- /dev/null +++ b/example/Views.hs @@ -0,0 +1,39 @@ +{-# 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" diff --git a/example/Weibo/test.hs b/example/Weibo/test.hs deleted file mode 100644 --- a/example/Weibo/test.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -{- - -weibo oauth2: http://open.weibo.com/wiki/Oauth2 - -This is very trivial testing of the httpclient api. -1. this case will print out a URL -2. run the URL in browser and will navigate to weibo auth page -3. conform the authentication and browser will navigate back to the callback url, - which obviously will failed cause there is no local server. -4. copy the `code` in the callback url and parse into console -5. this test case will gain access token using the `code` and print it out. - -check for integration testing at: -https://github.com/HaskellCNOrg/snaplet-oauth/tree/master/test - --} - -module Main where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.HTTP.Conduit -import Network.OAuth.OAuth2 -import URI.ByteString -import URI.ByteString.QQ - -import Keys - -import Data.Aeson -import Data.Aeson.Types -import GHC.Generics - -data Errors = - SomeRandomError - deriving (Show, Eq, Generic) - -instance FromJSON Errors where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True } - - -main :: IO () -main = do - print $ serializeURIRef' $ authorizationUrl weiboKey - putStrLn "visit the url and paste code here: " - code <- getLine - mgr <- newManager tlsManagerSettings - token <- fetchAccessToken mgr weiboKey (ExchangeToken $ T.pack code) - print token - case token of - Right r -> do - uid <- authGetBS' mgr (accessToken r) [uri|https://api.weibo.com/2/account/get_uid.json|] - print (uid :: OAuth2Result (OAuth2Error Errors) BSL.ByteString) - Left l -> print l - -sToBS :: String -> BS.ByteString -sToBS = T.encodeUtf8 . T.pack diff --git a/example/assets/main.css b/example/assets/main.css new file mode 100644 --- /dev/null +++ b/example/assets/main.css @@ -0,0 +1,11 @@ +body { + padding: 10px 50px; +} + +.login-with { + margin: 10px 0; + padding: 10px; + border: 1px solid grey; + border-radius: 5px; + width: 500px; +} diff --git a/example/demo-server.hs b/example/demo-server.hs deleted file mode 100644 --- a/example/demo-server.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main where - -import Control.Monad (mzero) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Char (chr) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.HTTP.Conduit hiding (Request, queryString) -import Network.HTTP.Types (Query, status200) -import Network.Wai -import Network.Wai.Handler.Warp (run) -import URI.ByteString (serializeURIRef') -import URI.ByteString.QQ - -import Keys (fitbitKey) -import Network.OAuth.OAuth2 - -import Data.Aeson -import Data.Aeson.Types -import GHC.Generics - ------------------------------------------------------------------------------- - -main :: IO () -main = do - print $ serializeURIRef' $ appendQueryParams [("state", state), ("scope", "profile")] $ authorizationUrl fitbitKey - putStrLn "visit the url to continue" - run 9988 application - -application :: Application -application request respond = do - response <- handleRequest requestPath request - respond $ responseLBS status200 [("Content-Type", "text/plain")] response - where - requestPath = T.intercalate "/" $ pathInfo request - -handleRequest :: Text -> Request -> IO BL.ByteString -handleRequest "favicon.ico" _ = return "" -handleRequest _ request = do - mgr <- newManager tlsManagerSettings - token <- getApiToken mgr $ getApiCode request - print token - user <- getApiUser mgr (accessToken token) - print user - return $ encode user - -getApiCode :: Request -> ExchangeToken -getApiCode request = - case M.lookup "code" queryMap of - Just code -> ExchangeToken $ T.decodeUtf8 code - Nothing -> Prelude.error "request doesn't include code" - where - queryMap = convertQueryToMap $ queryString request - -getApiToken :: Manager -> ExchangeToken -> IO OAuth2Token -getApiToken mgr code = do - result <- doJSONPostRequest mgr fitbitKey url $ body ++ [("state", state)] - case result of - Right token -> return token - Left (e :: OAuth2Error Errors) -> Prelude.error $ show e - where - (url, body) = accessTokenUrl fitbitKey code - -convertQueryToMap :: Query -> M.Map B.ByteString B.ByteString -convertQueryToMap query = - M.fromList $ map normalize query - where - normalize (k, Just v) = (k, v) - normalize (k, Nothing) = (k, B.empty) - -lazyBSToString :: BL.ByteString -> String -lazyBSToString s = map (chr . fromIntegral) (BL.unpack s) diff --git a/example/main.hs b/example/main.hs new file mode 100644 --- /dev/null +++ b/example/main.hs @@ -0,0 +1,6 @@ +module Main where + +import App (app) + +main :: IO () +main = app diff --git a/example/templates/index.mustache b/example/templates/index.mustache new file mode 100644 --- /dev/null +++ b/example/templates/index.mustache @@ -0,0 +1,30 @@ + + + + + +

Hello OAuth2

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

Notes

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

+ + diff --git a/hoauth2.cabal b/hoauth2.cabal --- a/hoauth2.cabal +++ b/hoauth2.cabal @@ -1,6 +1,6 @@ Name: hoauth2 -- http://wiki.haskell.org/Package_versioning_policy -Version: 1.6.3 +Version: 1.7.0 Synopsis: Haskell OAuth2 authentication client @@ -35,12 +35,23 @@ Extra-source-files: README.md example/Keys.hs.sample - example/Google/test.hs - example/Weibo/test.hs - example/Github/test.hs - example/Facebook/test.hs - example/Fitbit/test.hs - example/Douban/test.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 @@ -79,245 +90,30 @@ else ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -Executable test-weibo - if flag(test) - Buildable: True - else - Buildable: False - - main-is: Weibo/test.hs - other-modules: Keys - hs-source-dirs: example - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.13, - http-conduit >= 2.1 && < 2.4, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - uri-bytestring >= 0.2.3.1 && < 0.4, - aeson >= 0.11 && < 1.3, - hoauth2 - - 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 test-google - if flag(test) - Buildable: True - else - Buildable: False - - main-is: Google/test.hs - other-modules: Keys - hs-source-dirs: example - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.13, - http-conduit >= 2.1 && < 2.4, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - uri-bytestring >= 0.2.3.1 && < 0.4, - aeson >= 0.11 && < 1.3, - hoauth2 - - 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 test-github - if flag(test) - Buildable: True - else - Buildable: False - - main-is: Github/test.hs - other-modules: Keys - hs-source-dirs: example - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.13, - http-conduit >= 2.1 && < 2.4, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - uri-bytestring >= 0.2.3.1 && < 0.4, - aeson >= 0.11 && < 1.3, - hoauth2 - - 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 test-douban - if flag(test) - Buildable: True - else - Buildable: False - - main-is: Douban/test.hs - other-modules: Keys - hs-source-dirs: example - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.13, - http-conduit >= 2.1 && < 2.4, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - uri-bytestring >= 0.2.3.1 && < 0.4, - aeson >= 0.11 && < 1.3, - hoauth2 - - 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 test-facebook - if flag(test) - Buildable: True - else - Buildable: False - - main-is: Facebook/test.hs - other-modules: Keys - hs-source-dirs: example - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.13, - http-conduit >= 2.1 && < 2.4, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - uri-bytestring >= 0.2.3.1 && < 0.4, - aeson >= 0.11 && < 1.3, - hoauth2 - - 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 test-fitbit - if flag(test) - Buildable: True - else - Buildable: False - - main-is: Fitbit/test.hs - other-modules: Keys - 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.3, - containers >= 0.4 && < 0.6, - aeson >= 0.11 && < 1.3, - 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 - -Executable test-stackexchange - if flag(test) - Buildable: True - else - Buildable: False - - main-is: StackExchange/test.hs - other-modules: Keys - hs-source-dirs: example - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.13, - http-conduit >= 2.1 && < 2.4, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - uri-bytestring >= 0.2.3.1 && < 0.4, - aeson >= 0.11 && < 1.3, - hoauth2 - - 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 test-dropbox - if flag(test) - Buildable: True - else - Buildable: False - - main-is: Dropbox/test.hs - other-modules: Keys - hs-source-dirs: example - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.13, - http-conduit >= 2.1 && < 2.4, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - uri-bytestring >= 0.2.3.1 && < 0.4, - aeson >= 0.11 && < 1.3, - hoauth2 - - 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 test-okta - if flag(test) - Buildable: True - else - Buildable: False - - main-is: Okta/test.hs - other-modules: Keys - hs-source-dirs: example - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - http-types >= 0.11 && < 0.13, - http-conduit >= 2.1 && < 2.4, - text >= 0.11 && < 1.3, - bytestring >= 0.9 && < 0.11, - uri-bytestring >= 0.2.3.1 && < 0.4, - aeson >= 0.11 && < 1.3, - hoauth2 - - 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: demo-server.hs - other-modules: Keys + main-is: main.hs + other-modules: IDP, + App + 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, @@ -330,8 +126,17 @@ warp >= 3.2 && < 3.3, containers >= 0.4 && < 0.6, aeson >= 0.11 && < 1.3, - hoauth2 - + microlens >= 0.4.0 && < 0.5, + unordered-containers >= 0.2.8 && < 0.2.9, + wai-extra >= 3.0.21.0 && < 3.0.22.0, + wai-middleware-static == 0.8.1, + mustache >= 2.2.3 && < 2.3.0, + mtl >= 2.2.1 && < 2.3, + scotty == 0.10.0, + binary >= 0.8.3.0 && < 0.8.5, + parsec >= 3.1.11 && < 3.2.0 , + hashable >= 1.2.6 && < 1.3.0, + hoauth2 >= 1.6 && < 1.7 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields diff --git a/src/Network/OAuth/OAuth2/HttpClient.hs b/src/Network/OAuth/OAuth2/HttpClient.hs --- a/src/Network/OAuth/OAuth2/HttpClient.hs +++ b/src/Network/OAuth/OAuth2/HttpClient.hs @@ -7,17 +7,20 @@ module Network.OAuth.OAuth2.HttpClient ( -- * Token management fetchAccessToken, + fetchAccessToken2, fetchRefreshToken, + refreshAccessToken, doJSONPostRequest, doFlexiblePostRequest, doSimplePostRequest, -- * AUTH requests authGetJSON, authGetBS, - authGetBS', + authGetBS2, authPostJSON, authPostBS, - authPostBS', + authPostBS2, + authPostBS3, authRequest, -- * Utilities handleResponse, @@ -44,7 +47,9 @@ -- * Token management -------------------------------------------------- --- | Request (via POST method) "OAuth2 Token". +-- | Request OAuth2 Token +-- method: POST +-- authenticate in header fetchAccessToken :: Manager -- ^ HTTP connection manager -> OAuth2 -- ^ OAuth Data -> ExchangeToken -- ^ OAuth 2 Tokens @@ -52,17 +57,36 @@ 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. --- TODO: seems more approporate to rename to refreshAccessToken -fetchRefreshToken :: Manager -- ^ HTTP connection manager. +refreshAccessToken :: Manager -- ^ HTTP connection manager. -> OAuth2 -- ^ OAuth context -> RefreshToken -- ^ refresh token gained after authorization -> IO (OAuth2Result TR.Errors OAuth2Token) -fetchRefreshToken manager oa token = doFlexiblePostRequest manager oa uri body +refreshAccessToken manager oa token = doFlexiblePostRequest manager oa uri body where (uri, body) = refreshAccessTokenUrl oa token +{-# DEPRECATED fetchRefreshToken "Use refreshAccessToken" #-} +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. @@ -117,12 +141,13 @@ where upReq = updateRequestHeaders (Just token) . setMethod HT.GET -- | same to 'authGetBS' but set access token to query parameter rather than header -authGetBS' :: FromJSON err => Manager -- ^ HTTP connection manager. +authGetBS2 :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString -authGetBS' manager token url = do +authGetBS2 manager token url = do req <- uriToRequest (url `appendAccessToken` token) + -- print $ queryString req authRequest req upReq manager where upReq = updateRequestHeaders Nothing . setMethod HT.GET @@ -149,16 +174,28 @@ upReq = upHeaders . upBody -- | Conduct POST request with access token in the request body rather header -authPostBS' :: FromJSON err => Manager -- ^ HTTP connection manager. +authPostBS2 :: FromJSON err => Manager -- ^ HTTP connection manager. -> AccessToken -> URI -> PostBody -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString -authPostBS' manager token url pb = do +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