Initial import

.gitignore

@@ -0,0 +1,3 @@
+*.swp
+dist/
+cabal-dev/

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.

Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

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| <a href=#{oaUrl}>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

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)

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