From 3457bfd3a0e34d5c7581e57d2bfcc2045534d041 Mon Sep 17 00:00:00 2001 From: Tom Streller Date: Sun, 14 Jul 2013 11:11:44 +0200 Subject: [PATCH] Initial import --- .gitignore | 3 + LICENSE | 25 ++++++++ README.md | 0 Setup.lhs | 7 +++ Yesod/Auth/OAuth2.hs | 47 +++++++++++++++ Yesod/Auth/OAuth2/Internal.hs | 105 ++++++++++++++++++++++++++++++++++ yesod-auth-oauth2.cabal | 38 ++++++++++++ 7 files changed, 225 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100755 Setup.lhs create mode 100644 Yesod/Auth/OAuth2.hs create mode 100644 Yesod/Auth/OAuth2/Internal.hs create mode 100644 yesod-auth-oauth2.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..691ce27 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*.swp +dist/ +cabal-dev/ diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..11dc17a --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2008, Michael Snoyman. 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..e69de29 diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 0000000..06e2708 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs new file mode 100644 index 0000000..a9d5006 --- /dev/null +++ b/Yesod/Auth/OAuth2.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-} +module Yesod.Auth.OAuth2 where + +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import Yesod.Auth +import Yesod.Form +import Yesod.Core +import Yesod.Auth.OAuth2.Internal + +oauth2Url :: Text -> AuthRoute +oauth2Url name = PluginR name ["forward"] + +authOAuth2 name oauth = AuthPlugin name dispatch login + where + url = PluginR name ["callback"] + dispatch "GET" ["forward"] = do + tm <- getRouteToParent + lift $ do + render <- getUrlRender + let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } + redirect $ authorizationUrl oauth' + dispatch "GET" ["callback"] = do + code <- lift $ runInputGet $ ireq textField "code" + mtoken <- liftIO $ postAccessToken oauth (encodeUtf8 code) (Just "authorization_code") + undefined + disptach _ _ = notFound + login tm = do + render <- getUrlRender + let oaUrl = render $ tm $ oauth2Url name + [whamlet| Login via #{name} |] + +oauth2Goodle clientId clientSecret = newOAuth2 { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" + , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" } + +oauth2Cloudsdale clientId clientSecret = newOAuth2 { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = "http://www.cloudsdale.org/oauth/authorize" + , oauthAccessTokenEndpoint = "http://www.cloudsdale.org/oauth/token" } + +bsToText :: ByteString -> Text +bsToText = decodeUtf8With lenientDecode diff --git a/Yesod/Auth/OAuth2/Internal.hs b/Yesod/Auth/OAuth2/Internal.hs new file mode 100644 index 0000000..f86f4fe --- /dev/null +++ b/Yesod/Auth/OAuth2/Internal.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Yesod.Auth.OAuth2.Internal where + +{- see https://gist.github.com/qzchenwl/2351071 -} + +import Data.Aeson +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.ByteString.Lazy (toChunks) +import Data.List +import Data.Maybe +import Data.Typeable (Typeable) +import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery) +import qualified Network.HTTP.Types as HT +import Network.HTTP.Conduit as C +import Control.Exception +import Control.Applicative ((<$>)) +import Control.Monad (mzero) + +data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString + , oauthClientSecret :: BS.ByteString + , oauthOAuthorizeEndpoint :: BS.ByteString + , oauthAccessTokenEndpoint :: BS.ByteString + , oauthCallback :: Maybe BS.ByteString + , oauthAccessToken :: Maybe BS.ByteString + } deriving (Show, Eq) + +data OAuthException = OAuthException String + deriving (Show, Eq, Typeable) + +instance Exception OAuthException + +newOAuth2 :: OAuth2 +newOAuth2 = OAuth2 { oauthClientId = error "You must specify client id." + , oauthClientSecret = error "You must specify client secret." + , oauthOAuthorizeEndpoint = error "You must specify authorize endpoint." + , oauthAccessTokenEndpoint = error "You must specify access_token endpoint." + , oauthCallback = Nothing + , oauthAccessToken = Nothing + } + +authorizationUrl :: OAuth2 -> BS.ByteString +authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryString + where queryString = renderSimpleQuery True query + query = foldr step [] [ ("client_id", Just $ oauthClientId oa) + , ("response_type", Just "code") + , ("redirect_uri", oauthCallback oa)] + +request req = (withManager . httpLbs) (req { checkStatus = \_ _ _ -> Nothing }) + +getAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString +getAccessToken' oa code grant_type = do + rsp <- request req + if (HT.statusCode . responseStatus) rsp == 200 + then return $ responseBody rsp + else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp) + where + req = fromJust $ parseUrl url + url = BS.unpack $ oauthAccessTokenEndpoint oa `BS.append` queryString + queryString = renderSimpleQuery True query + query = foldr step [] [ ("client_id", Just $ oauthClientId oa) + , ("client_secret", Just $ oauthClientSecret oa) + , ("code", Just code) + , ("redirect_uri", oauthCallback oa) + , ("grant_type", grant_type) ] + +postAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString +postAccessToken' oa code grant_type = do + rsp <- request req + if (HT.statusCode . responseStatus) rsp == 200 + then return $ responseBody rsp + else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp) + where + toPost r = r { method = "POST" } + req = urlEncodedBody query . toPost . fromJust $ parseUrl url + url = BS.unpack $ oauthAccessTokenEndpoint oa + query = foldr step [] [ ("client_id", Just $ oauthClientId oa) + , ("client_secret", Just $ oauthClientSecret oa) + , ("code", Just code) + , ("redirect_uri", oauthCallback oa) + , ("grant_type", grant_type) ] + +step :: (a, Maybe b) -> [(a, b)] -> [(a, b)] +step (a, Just b) xs = (a, b):xs +step _ xs = xs + +getAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken) +getAccessToken oa code grant_type = decode <$> getAccessToken' oa code grant_type + +postAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken) +postAccessToken oa code grant_type = decode <$> postAccessToken' oa code grant_type + +data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show) +instance FromJSON AccessToken where + parseJSON (Object o) = AccessToken <$> o .: "access_token" + parseJSON _ = mzero + +signRequest :: OAuth2 -> Request m -> Request m +signRequest oa req = req { queryString = (renderSimpleQuery False newQuery) } + where + newQuery = case oauthAccessToken oa of + Just at -> insert ("oauth_token", at) oldQuery + _ -> insert ("client_id", oauthClientId oa) . insert ("client_secret", oauthClientSecret oa) $ oldQuery + oldQuery = parseSimpleQuery (queryString req) diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal new file mode 100644 index 0000000..765ffa2 --- /dev/null +++ b/yesod-auth-oauth2.cabal @@ -0,0 +1,38 @@ +name: yesod-auth-oauth2 +version: 0.0.1 +license: BSD3 +license-file: LICENSE +author: Tom Streller +maintainer: Tom Streller +synopsis: Library to authenticate with OAuth 2.0 for Yesod web applications. +description: OAuth 2.0 authentication +category: Web +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://github.com/scan/yesod-auth-oauth2 + +flag ghc7 + +library + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + build-depends: bytestring >= 0.9.1.4 + , http-conduit >= 1.9 && < 2 + , http-types >= 0.8 && < 0.9 + , aeson >= 0.6 && < 0.7 + , yesod-core >= 1.2 && < 1.3 + , yesod-auth >= 1.2 && < 1.3 + , text >= 0.7 && < 0.12 + , yesod-form >= 1.3 && < 1.4 + , transformers >= 0.2.2 && < 0.4 + exposed-modules: Yesod.Auth.OAuth2 + other-modules: Yesod.Auth.OAuth2.Internal + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/scan/authenticate-oauth2.git