diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,68 @@ + +HC=ghc +DIST=dist +CDEV=cabal-dev +STYLE=stylish-haskell + + +.PHONY: clean test hlint + +default: build + +init: + cabal update + $(CDEV) install --only-dependencies + +clean: + rm -rf $(DIST) + rm -rf ./cabal-dev/lib/snaplet-oauth* + rm -rf ./cabal-dev/packages/snaplet-oauth* + rm -f ./cabal-dev/packages-7.4.1.conf/snaplet-oauth-* + +hlint: + hlint src/ tests/ --report=$(DIST)/hlint.html + find src tests example -name '*.hs' | xargs $(STYLE) -i + +conf: + $(CDEV) configure --enable-tests + +build: conf + $(CDEV) build + +rebuild: clean build + +install: build + $(CDEV) install --enable-tests + +reinstall: clean install + +test: build + $(CDEV) test + +demo: + cd example && make clean p + +doc: + $(CDEV) haddock + +dist: clean build + $(CDEV) sdist + +### build before push in case compilation error + +push: clean build + git push --all + +fun: + cloc src + cloc tests + +local: + rm -rf ./cabal-dev/lib/hoauth2* + rm -rf ./cabal-dev/packages/hoauth2* + rm -f ./cabal-dev/packages-7.4.1.conf/hoauth2-* + $(CDEV) add-source ../hoauth2 + $(CDEV) install + +## +## cd example/ && runghc -package-conf=../cabal-dev/packages-7.4.1.conf/ snap.hs -b 127.0.0.1 -p 9988 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ + + +- master: [![master](https://secure.travis-ci.org/HaskellCNOrg/snaplet-oauth.png?branch=master)](http://travis-ci.org/HaskellCNOrg/snap-oauth) +- branch/0.0.6: [![Build Status](https://travis-ci.org/HaskellCNOrg/snaplet-oauth.png?branch=branch/0.0.6)](https://travis-ci.org/HaskellCNOrg/snaplet-oauth) + +snaplet-oauth +============= + +oauth client snaplet + +support oauth providers + + - [weibo](http://weib.com) + - [google](https://developers.google.com/accounts/docs/OAuth2WebServer) + - github + +Build & Tests +============= + + - `make init rebuild` + - `make test` + +Demo +============= + + 1. `cd example` + 2. update `src/Keys.hs.default` and rename to `Keys.hs` + 3. make clean prev + + +snaplet +============= + +- [what is snaplet] + +[what is snaplet]: http://snapframework.com/docs/tutorials/snaplets-tutorial diff --git a/example/Makefile b/example/Makefile new file mode 100644 --- /dev/null +++ b/example/Makefile @@ -0,0 +1,31 @@ + +DIST=dist +CDEV=cabal-dev --sandbox=../cabal-dev +TARGET=./dist/build/example/example + +.PHONY: example + +default: build + +init: + cabal update + $(CDEV) install + +clean: + rm -rf $(DIST) + +conf: + $(CDEV) configure --flags="development" + +build: conf + $(CDEV) build + +rebuild: clean build + +install: build + $(CDEV) install + +p: build + $(TARGET) -p 9988 + +# cd example/ && runghc -package-conf=../cabal-dev/packages-7.4.1.conf/ snap.hs -b 127.0.0.1 -p 9988 diff --git a/example/example.cabal b/example/example.cabal new file mode 100644 --- /dev/null +++ b/example/example.cabal @@ -0,0 +1,55 @@ +Name: example +Version: 0.1 +Synopsis: Project Synopsis Here +Description: Project Description Here +License: AllRightsReserved +Author: Author +Maintainer: maintainer@example.com +Stability: Experimental +Category: Web +Build-type: Simple +Cabal-version: >=1.2 + +Flag development + Description: Whether to build the server in development (interpreted) mode + Default: False + +Executable example + hs-source-dirs: src + main-is: Main.hs + + Build-depends: + base >= 4 && < 5, + bytestring >= 0.9.1 && < 0.10, + data-lens >= 2.0.1 && < 2.11, + data-lens-template >= 2.1 && < 2.2, + heist >= 0.8 && < 0.9, + MonadCatchIO-transformers >= 0.2.1 && < 0.4, + mtl >= 2 && < 3, + snap == 0.9.*, + snap-core == 0.9.*, + snap-server == 0.9.*, + snap-loader-static == 0.9.*, + text >= 0.11 && < 0.12, + time >= 1.1 && < 1.5, + xmlhtml >= 0.1, + snaplet-oauth >= 0.0.6 && < 0.0.7, + unordered-containers >= 0.2.2 && < 0.3 + + if flag(development) + build-depends: + snap-loader-dynamic == 0.9.* + cpp-options: -DDEVELOPMENT + -- In development mode, speed is already going to suffer, so skip + -- the fancy optimization flags. Additionally, disable all + -- warnings. The hint library doesn't give an option to execute + -- compiled code when there were also warnings, so disabling + -- warnings allows quicker workflow. + ghc-options: -threaded -w + else + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-orphans -fno-warn-unused-do-bind + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-orphans diff --git a/example/snaplets/heist/templates/_login.tpl b/example/snaplets/heist/templates/_login.tpl new file mode 100644 --- /dev/null +++ b/example/snaplets/heist/templates/_login.tpl @@ -0,0 +1,21 @@ +

Snap Example App Login

+ +

+ +/login +Login + + +

Don't have a login yet? Create a new user

+ + diff --git a/example/snaplets/heist/templates/_new_user.tpl b/example/snaplets/heist/templates/_new_user.tpl new file mode 100644 --- /dev/null +++ b/example/snaplets/heist/templates/_new_user.tpl @@ -0,0 +1,5 @@ +

Register a new user

+ +/new_user +Add User + diff --git a/example/snaplets/heist/templates/base.tpl b/example/snaplets/heist/templates/base.tpl new file mode 100644 --- /dev/null +++ b/example/snaplets/heist/templates/base.tpl @@ -0,0 +1,13 @@ + + + Snap web server + + + +
+ + + +
+ + diff --git a/example/snaplets/heist/templates/index.tpl b/example/snaplets/heist/templates/index.tpl new file mode 100644 --- /dev/null +++ b/example/snaplets/heist/templates/index.tpl @@ -0,0 +1,22 @@ + + + +

+ This is a simple demo page served using + Heist + and the Snap web framework. +

+ +

Congrats! You're logged in as ''

+

+ +

Home

+

Logout

+ + + + + + + + diff --git a/example/snaplets/heist/templates/login.tpl b/example/snaplets/heist/templates/login.tpl new file mode 100644 --- /dev/null +++ b/example/snaplets/heist/templates/login.tpl @@ -0,0 +1,3 @@ + + + diff --git a/example/snaplets/heist/templates/new_user.tpl b/example/snaplets/heist/templates/new_user.tpl new file mode 100644 --- /dev/null +++ b/example/snaplets/heist/templates/new_user.tpl @@ -0,0 +1,3 @@ + + + diff --git a/example/snaplets/heist/templates/userform.tpl b/example/snaplets/heist/templates/userform.tpl new file mode 100644 --- /dev/null +++ b/example/snaplets/heist/templates/userform.tpl @@ -0,0 +1,14 @@ +
+ + + + + + + + + + + +
Login:
Password:
+
diff --git a/example/src/Application.hs b/example/src/Application.hs new file mode 100644 --- /dev/null +++ b/example/src/Application.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + +------------------------------------------------------------------------------ +-- | This module defines our application's state type and an alias for its +-- handler monad. +module Application where + +------------------------------------------------------------------------------ +import Data.Lens.Template +import Snap.Snaplet +import Snap.Snaplet.Auth +import Snap.Snaplet.Heist +import Snap.Snaplet.OAuth +import Snap.Snaplet.Session + +------------------------------------------------------------------------------ +data App = App + { _heist :: Snaplet (Heist App) + , _sess :: Snaplet SessionManager + , _auth :: Snaplet (AuthManager App) + , _oauth :: Snaplet OAuthSnaplet + } + +makeLens ''App + +instance HasHeist App where + heistLens = subSnaplet heist + +instance HasOAuth App where + oauthLens = oauth + +------------------------------------------------------------------------------ + +type AppHandler = Handler App App + + diff --git a/example/src/Keys.hs.default b/example/src/Keys.hs.default new file mode 100644 --- /dev/null +++ b/example/src/Keys.hs.default @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Keys where + +import Snap.Snaplet.OAuth + +---------------------------------------------------------------------- + +keys = [ (weibo, weiboKey) + , (google, googleKey) + , (github, githubKey) + ] + +---------------------------------------------------------------------- + +googleKey :: OAuth2 +googleKey = OAuth2 { oauthClientId = "" + , oauthClientSecret = "" + , oauthCallback = Just "http://127.0.0.1:9988/googleCallback" + , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" + , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" + , oauthAccessToken = Nothing + } + +weiboKey :: OAuth2 +weiboKey = OAuth2 { oauthClientId = "" + , oauthClientSecret = "" + , oauthCallback = Just "http://127.0.0.1:9988/oauthCallback" + , oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/authorize" + , oauthAccessTokenEndpoint = "https://api.weibo.com/oauth2/access_token" + , oauthAccessToken = Nothing + } +githubKey :: OAuth2 +githubKey = undefined diff --git a/example/src/Main.hs b/example/src/Main.hs new file mode 100644 --- /dev/null +++ b/example/src/Main.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +------------------------------------------------------------------------------ +import Control.Exception (SomeException, try) +import qualified Data.Text as T +import Site +import Snap.Core +import Snap.Http.Server +import Snap.Snaplet +import Snap.Snaplet.Config +import System.IO + +#ifdef DEVELOPMENT +import Snap.Loader.Dynamic +#else +import Snap.Loader.Static +#endif + + +------------------------------------------------------------------------------ +-- | This is the entry point for this web server application. It supports +-- easily switching between interpreting source and running statically compiled +-- code. +-- +-- In either mode, the generated program should be run from the root of the +-- project tree. When it is run, it locates its templates, static content, and +-- source files in development mode, relative to the current working directory. +-- +-- When compiled with the development flag, only changes to the libraries, your +-- cabal file, or this file should require a recompile to be picked up. +-- Everything else is interpreted at runtime. There are a few consequences of +-- this. +-- +-- First, this is much slower. Running the interpreter takes a significant +-- chunk of time (a couple tenths of a second on the author's machine, at this +-- time), regardless of the simplicity of the loaded code. In order to +-- recompile and re-load server state as infrequently as possible, the source +-- directories are watched for updates, as are any extra directories specified +-- below. +-- +-- Second, the generated server binary is MUCH larger, since it links in the +-- GHC API (via the hint library). +-- +-- Third, and the reason you would ever want to actually compile with +-- development mode, is that it enables a faster development cycle. You can +-- simply edit a file, save your changes, and hit reload to see your changes +-- reflected immediately. +-- +-- When this is compiled without the development flag, all the actions are +-- statically compiled in. This results in faster execution, a smaller binary +-- size, and having to recompile the server for any code change. +-- +main :: IO () +main = do + -- Depending on the version of loadSnapTH in scope, this either enables + -- dynamic reloading, or compiles it without. The last argument to + -- loadSnapTH is a list of additional directories to watch for changes to + -- trigger reloads in development mode. It doesn't need to include source + -- directories, those are picked up automatically by the splice. + (conf, site, cleanup) <- $(loadSnapTH [| getConf |] + 'getActions + ["snaplets/heist/templates"]) + + _ <- try $ httpServe conf site :: IO (Either SomeException ()) + cleanup + + +------------------------------------------------------------------------------ +-- | This action loads the config used by this application. The loaded config +-- is returned as the first element of the tuple produced by the loadSnapTH +-- Splice. The type is not solidly fixed, though it must be an IO action that +-- produces the same type as 'getActions' takes. It also must be an instance of +-- Typeable. If the type of this is changed, a full recompile will be needed to +-- pick up the change, even in development mode. +-- +-- This action is only run once, regardless of whether development or +-- production mode is in use. +getConf :: IO (Config Snap AppConfig) +getConf = commandLineAppConfig defaultConfig + + +------------------------------------------------------------------------------ +-- | This function generates the the site handler and cleanup action from the +-- configuration. In production mode, this action is only run once. In +-- development mode, this action is run whenever the application is reloaded. +-- +-- Development mode also makes sure that the cleanup actions are run +-- appropriately before shutdown. The cleanup action returned from loadSnapTH +-- should still be used after the server has stopped handling requests, as the +-- cleanup actions are only automatically run when a reload is triggered. +-- +-- This sample doesn't actually use the config passed in, but more +-- sophisticated code might. +getActions :: Config Snap AppConfig -> IO (Snap (), IO ()) +getActions conf = do + (msgs, site, cleanup) <- runSnaplet + (appEnvironment =<< getOther conf) app + hPutStrLn stderr $ T.unpack msgs + return (site, cleanup) diff --git a/example/src/OAuthHandlers.hs b/example/src/OAuthHandlers.hs new file mode 100644 --- /dev/null +++ b/example/src/OAuthHandlers.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} + +module OAuthHandlers + ( routes ) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Auth +import Snap.Snaplet.Auth.Backends.JsonFile +import Snap.Snaplet.Heist +import Snap.Snaplet.OAuth +import Text.Templating.Heist + + +import qualified Snap.Snaplet.OAuth.Github as GH +import qualified Snap.Snaplet.OAuth.Google as G +import qualified Snap.Snaplet.OAuth.Weibo as W + +import Application +import Splices + +---------------------------------------------------------------------- +-- Weibo +---------------------------------------------------------------------- + +-- | Logs out and redirects the user to the site index. +weiboOauthCallbackH :: AppHandler () +weiboOauthCallbackH = W.weiboUserH + >>= success + where success Nothing = writeBS "No user info found" + success (Just usr) = do + with auth $ createOAuthUser weibo $ W.wUidStr usr + --writeText $ T.pack $ show usr + toHome usr + + +---------------------------------------------------------------------- +-- Google +---------------------------------------------------------------------- + +googleOauthCallbackH :: AppHandler () +googleOauthCallbackH = G.googleUserH + >>= googleUserId + +googleUserId :: Maybe G.GoogleUser -> AppHandler () +googleUserId Nothing = redirect "/" +googleUserId (Just user) = with auth (createOAuthUser google (G.gid user)) + >> toHome user + +---------------------------------------------------------------------- +-- Github +---------------------------------------------------------------------- + +githubOauthCallbackH :: AppHandler () +githubOauthCallbackH = GH.githubUserH + >>= githubUser + +githubUser :: Maybe GH.GithubUser -> AppHandler () +githubUser Nothing = redirect "/" +githubUser (Just user) = with auth (createOAuthUser github uid) + >> toHome user + where uid = intToText $ GH.gid user + intToText = T.pack . show + + +---------------------------------------------------------------------- +-- Create User per oAuth response +---------------------------------------------------------------------- + +-- | Create new user for Weibo User to local +-- +createOAuthUser :: OAuthKey + -> T.Text -- ^ oauth user id + -> Handler App (AuthManager App) () +createOAuthUser key name = do + let name' = textToBS name + passwd = ClearText name' + role = Role (BS.pack $ show key) + exists <- usernameExists name + unless exists (void (createUser name name')) + res <- loginByUsername name' passwd False + case res of + Left l -> liftIO $ print l + Right r -> do + res2 <- saveUser (r {userRoles = [ role ]}) + return () + --either (liftIO . print) (const $ return ()) res2 + +---------------------------------------------------------------------- +-- Routes +---------------------------------------------------------------------- + +-- | The application's routes. +routes :: [(ByteString, AppHandler ())] +routes = [ ("/oauthCallback", weiboOauthCallbackH) + , ("/googleCallback", googleOauthCallbackH) + , ("/githubCallback", githubOauthCallbackH) + ] + +-- | NOTE: when use such way to show callback result, +-- the url does not change, which can not be invoke twice. +-- This is quite awkful thing and only for testing purpose. +-- +toHome a = heistLocal (bindRawResponseSplices a) $ render "index" + +---------------------------------------------------------------------- +-- +---------------------------------------------------------------------- diff --git a/example/src/Site.hs b/example/src/Site.hs new file mode 100644 --- /dev/null +++ b/example/src/Site.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------ +-- | This module is where all the routes and handlers are defined for your +-- site. The 'app' function is the initializer that combines everything +-- together and is exported by this module. +module Site + ( app + ) where + +------------------------------------------------------------------------------ +import Control.Applicative +import Data.ByteString (ByteString) +import qualified Data.HashMap.Strict as M +import Data.Maybe +import qualified Data.Text as T +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Auth +import Snap.Snaplet.Auth.Backends.JsonFile +import Snap.Snaplet.Heist +import Snap.Snaplet.OAuth +import Snap.Snaplet.Session.Backends.CookieSession +import Snap.Util.FileServe +import Text.Templating.Heist + +------------------------------------------------------------------------------ + +import Application +import Keys +import qualified OAuthHandlers as OA + +------------------------------------------------------------------------------ +-- | Render login form +handleLogin :: Maybe T.Text -> Handler App (AuthManager App) () +handleLogin authError = heistLocal (bindSplices errs) $ render "login" + where + errs = [("loginError", textSplice c) | c <- maybeToList authError] + + +------------------------------------------------------------------------------ +-- | Handle login submit +handleLoginSubmit :: Handler App (AuthManager App) () +handleLoginSubmit = + loginUser "login" "password" Nothing + (\_ -> handleLogin err) (redirect "/") + where + err = Just "Unknown user or password" + + +------------------------------------------------------------------------------ +-- | Logs out and redirects the user to the site index. +handleLogout :: Handler App (AuthManager App) () +handleLogout = logout >> redirect "/" + + +------------------------------------------------------------------------------ +-- | Handle new user form submit +handleNewUser :: Handler App (AuthManager App) () +handleNewUser = method GET handleForm <|> method POST handleFormSubmit + where + handleForm = render "new_user" + handleFormSubmit = registerUser "login" "password" >> redirect "/" + + +------------------------------------------------------------------------------ +-- | The application's routes. +routes :: [(ByteString, Handler App App ())] +routes = [ ("/login", with auth handleLoginSubmit) + , ("/logout", with auth handleLogout) + , ("/new_user", with auth handleNewUser) + ] + <|> + OA.routes + <|> + [ ("", serveDirectory "static") ] + + +------------------------------------------------------------------------------ +-- | The application initializer. +app :: SnapletInit App App +app = makeSnaplet "app" "An snaplet example application." Nothing $ do + h <- nestSnaplet "" heist $ heistInit "templates" + s <- nestSnaplet "sess" sess $ + initCookieSessionManager "site_key.txt" "sess" (Just 3600) + + -- NOTE: We're using initJsonFileAuthManager here because it's easy and + -- doesn't require any kind of database server to run. In practice, + -- you'll probably want to change this to a more robust auth backend. + a <- nestSnaplet "auth" auth $ + initJsonFileAuthManager defAuthSettings sess "users.json" + + -- + -- NOTE: if defined as: + -- oa <- nestSnaplet "oauth" oauth $ initOauthSnaplet + -- the url becomes /oauth/weibo + -- + oa <- nestSnaplet "oauth" oauth $ initOauthSnaplet True oauthkeys + addRoutes routes + addAuthSplices auth + return $ App h s a oa + +oauthkeys :: OAuthMap +oauthkeys = OAuthMap $ M.fromList Keys.keys diff --git a/example/src/Splices.hs b/example/src/Splices.hs new file mode 100644 --- /dev/null +++ b/example/src/Splices.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Splices where + +import Snap.Snaplet.OAuth +import Text.Templating.Heist + +---------------------------------------------------------------------- +-- Splices +---------------------------------------------------------------------- + + +rawResponseSplices :: (Monad m, Show a) => a -> Splice m +rawResponseSplices = textSplice . sToText + +bindRawResponseSplices :: (Monad m, Show a) + => a + -> HeistState m + -> HeistState m +bindRawResponseSplices value = bindSplice "rawResponseSplices" (rawResponseSplices value) diff --git a/example/static/screen.css b/example/static/screen.css new file mode 100644 --- /dev/null +++ b/example/static/screen.css @@ -0,0 +1,26 @@ +html { + padding: 0; + margin: 0; + background-color: #ffffff; + font-family: Verdana, Helvetica, sans-serif; +} +body { + padding: 0; + margin: 0; +} +a { + text-decoration: underline; +} +a :hover { + cursor: pointer; + text-decoration: underline; +} +img { + border: none; +} +#content { + padding-left: 1em; +} +#info { + font-size: 60%; +} diff --git a/snaplet-oauth.cabal b/snaplet-oauth.cabal --- a/snaplet-oauth.cabal +++ b/snaplet-oauth.cabal @@ -1,9 +1,9 @@ Name: snaplet-oauth -Version: 0.0.5 +Version: 0.0.6 Synopsis: snaplet-oauth Description: This lib is in Alpha status and APIs are likely to be changed. -Homepage: freizl.github.com +Homepage: https://github.com/HaskellCNOrg/snaplet-oauth License: BSD3 License-file: LICENSE Author: Haisheng,Wu @@ -12,48 +12,69 @@ Category: Web Build-type: Simple stability: alpha +Cabal-version: >=1.10 + -- Extra files to be distributed with the package, such as examples or -- a README. --- Extra-source-files: +Extra-source-files: + README.md + Makefile + tests/Weibo.hs + example/example.cabal + example/Makefile + example/snaplets/heist/templates/*.tpl + example/src/Splices.hs + example/src/Site.hs + example/src/OAuthHandlers.hs + example/src/Main.hs + example/src/Application.hs + example/src/Keys.hs.default + example/static/*.css -Cabal-version: >=1.10 +Source-Repository head + Type: git + Location: git://github.com/HaskellCNOrg/snaplet-oauth.git + + Library default-language: Haskell2010 Hs-Source-Dirs: src Exposed-modules: Snap.Snaplet.OAuth - Snap.Snaplet.OAuth.Internal.Types - Snap.Snaplet.OAuth.Internal.Handlers - Snap.Snaplet.OAuth.Internal.Utils Snap.Snaplet.OAuth.Weibo Snap.Snaplet.OAuth.Google + Snap.Snaplet.OAuth.Github Other-Modules: + Snap.Snaplet.OAuth.Internal.Types + Snap.Snaplet.OAuth.Internal.Handlers + Snap.Snaplet.OAuth.Internal.Utils Snap.Snaplet.OAuth.Weibo.Api Snap.Snaplet.OAuth.Google.Api + Snap.Snaplet.OAuth.Github.Api Build-Depends: + MonadCatchIO-mtl >= 0.3 && < 0.4, + aeson >= 0.6 && < 0.7, base >= 4 && < 5, bytestring >= 0.9 && < 1.0, - data-lens >= 2.0.1 && < 2.11, - text >= 0.11 && < 0.12, bytestring-show >= 0.3.5 && < 0.4, - aeson >= 0.6 && < 0.7, - data-lens-template == 2.1.*, + data-lens >= 2.0 && < 2.1, + data-lens-template >= 2.1 && < 2.2, failure >= 0.1, + hashable >= 1.1.2 && < 1.2, + heist == 0.8.*, + hoauth2 >= 0.2.6 && < 0.2.7, + http-conduit >= 1.8.3 && < 1.8.5, + http-types >= 0.7 && < 0.8, snap == 0.9.*, snap-core == 0.9.*, snap-loader-dynamic == 0.9.*, snap-loader-static == 0.9.*, - heist == 0.8.*, - MonadCatchIO-mtl >= 0.3 && < 0.4, - unordered-containers >= 0.2 && < 0.3, - hashable >= 1.1.2 && < 1.2, - http-types >= 0.7 && < 0.8, - http-conduit >= 1.6 && < 1.7, - hoauth2 == 0.2.4 + text >= 0.11 && < 0.12, + unordered-containers >= 0.2 && < 0.3 if impl(ghc >= 6.12.0) @@ -76,7 +97,7 @@ base >= 4 && < 5, bytestring >= 0.9 && < 1.0, bytestring-show >= 0.3 && < 0.4, - test-framework >= 0.6 && < 0.7, - test-framework-hunit >= 0.2 && < 0.3, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2 && < 0.4, text >= 0.11 && < 0.12, - snaplet-oauth >= 0.0.5 && < 0.0.6 + snaplet-oauth >= 0.0.5 && < 0.0.7 diff --git a/src/Snap/Snaplet/OAuth.hs b/src/Snap/Snaplet/OAuth.hs --- a/src/Snap/Snaplet/OAuth.hs +++ b/src/Snap/Snaplet/OAuth.hs @@ -8,9 +8,11 @@ , module TY ) where import Data.ByteString (ByteString) +import Data.HashMap.Strict (member) import Snap -import Network.OAuth2.OAuth2 as OA +import Network.OAuth.OAuth2 as OA +import qualified Snap.Snaplet.OAuth.Github as GH import qualified Snap.Snaplet.OAuth.Google as G import Snap.Snaplet.OAuth.Internal.Handlers as HS import Snap.Snaplet.OAuth.Internal.Types as TY @@ -28,14 +30,16 @@ -- ^ Oauth Keys -> SnapletInit b OAuthSnaplet initOauthSnaplet rt oauths = - makeSnaplet "OAuthSnaplet" "" Nothing $ do - when rt (addRoutes routes) - return $ emptyOAuthSnaplet { oauthKeys = oauths } + makeSnaplet "OAuth" "Snaplet - OAuth Client" Nothing $ do + when rt (addDefaultRouters oauths) + return $ emptyOAuthSnaplet { oauthKeys = oauths } --- | Snap Handlers --- ?? TODO: add routes per config [weibo, google, github] --- -routes :: HasOAuth b => [(ByteString, Handler b v ())] -routes = W.routes - <|> - G.routes +addDefaultRouters :: HasOAuth b => OAuthMap -> Initializer b v () +addDefaultRouters (OAuthMap maps) = addRoutes $ concat + [ r | (k, r) <- defaultRoutes, k `member` maps ] + +defaultRoutes :: HasOAuth b => [(OAuthKey, [(ByteString, Handler b v ())])] +defaultRoutes = [ (weibo, W.routes) + , (google, G.routes) + , (github, GH.routes) + ] diff --git a/src/Snap/Snaplet/OAuth/Github.hs b/src/Snap/Snaplet/OAuth/Github.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Github.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Snap.Snaplet.OAuth.Github + ( + -- * Routes + routes + -- * Handlers + , githubLoginH + , githubCallbackH + , githubUserH + -- * Types and API + , module Snap.Snaplet.OAuth.Github.Api + ) where + +------------------------------------------------------------------------------ +import Control.Category +import Control.Monad +import Data.ByteString (ByteString) +import Data.Maybe +import Prelude hiding ((.)) +import Snap + +import Snap.Snaplet.OAuth.Github.Api +import Snap.Snaplet.OAuth.Internal.Handlers +import Snap.Snaplet.OAuth.Internal.Types + +------------------------------------------------------------------------------ +-- Github +------------------------------------------------------------------------------ + +githubLoginH :: HasOAuth b => Handler b v () +githubLoginH = loginWithOauthH github Nothing + + +-- | token access callback. +-- return a @OAuthValue@ having access token has been filled. +-- +githubCallbackH :: HasOAuth b => Handler b v OAuthValue +githubCallbackH = oauthCallbackH github + +-- | token access callback +-- return a @Maybe@ @GithubUser@ if everything goes well otherwise @Nothing@. +-- +githubUserH :: HasOAuth b => Handler b v (Maybe GithubUser) +githubUserH = githubCallbackH >>= liftIO . apiUser + + +------------------------------------------------------------------------------ + +-- | The application's routes. +-- +routes :: HasOAuth b => [(ByteString, Handler b v ())] +routes = [ ("/github" , githubLoginH) + ] + -- where the callback handler is suppose to be added by user. + + +---------------------------------------------------------------------------- diff --git a/src/Snap/Snaplet/OAuth/Github/Api.hs b/src/Snap/Snaplet/OAuth/Github/Api.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Github/Api.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- + + +-} + +module Snap.Snaplet.OAuth.Github.Api where + +import Control.Applicative +import Control.Monad (mzero) +import Data.Aeson +import qualified Data.ByteString as BS +import Data.Text (Text) + +import Snap.Snaplet.OAuth.Internal.Types +import Snap.Snaplet.OAuth.Internal.Utils + + +---------------------------------------------------------------------- +-- APIs Impl +---------------------------------------------------------------------- + +-- | TODO: maybe need email infomation +-- +data GithubUser = GithubUser { gid :: Integer + , gname :: Text + , glogin :: Text + , glink :: Text + } deriving (Show, Eq) + +instance FromJSON GithubUser where + parseJSON (Object o) = GithubUser + <$> o .: "id" + <*> o .: "name" + <*> o .: "login" + <*> o .: "html_url" + parseJSON _ = mzero + +---------------------------------------------------------------------- +-- APIs Impl +---------------------------------------------------------------------- + + +apiUser :: OAuthValue -> IO (Maybe GithubUser) +apiUser = apiRequestOAuth apiUrlUser + + +---------------------------------------------------------------------- +-- APIs URI +---------------------------------------------------------------------- + +-- | Possible operations of UserInfo +-- +apiUrlUser :: BS.ByteString +apiUrlUser = "https://api.github.com/user" diff --git a/src/Snap/Snaplet/OAuth/Google.hs b/src/Snap/Snaplet/OAuth/Google.hs --- a/src/Snap/Snaplet/OAuth/Google.hs +++ b/src/Snap/Snaplet/OAuth/Google.hs @@ -3,22 +3,26 @@ {-# LANGUAGE RankNTypes #-} module Snap.Snaplet.OAuth.Google - ( routes - , loginWithGoogleH + ( + -- * Routes + routes + -- * Handlers + , googleLoginH , googleCallbackH - , userInfoH + , googleUserH + -- * Types and API , module Snap.Snaplet.OAuth.Google.Api ) where ------------------------------------------------------------------------------ import Control.Category import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Data.Maybe import Network.HTTP.Types (renderSimpleQuery) import Prelude hiding ((.)) import Snap -import Network.OAuth2.OAuth2 import Snap.Snaplet.OAuth.Google.Api import Snap.Snaplet.OAuth.Internal.Handlers import Snap.Snaplet.OAuth.Internal.Types @@ -27,28 +31,27 @@ -- Google ------------------------------------------------------------------------------ --- | FIXME: How to support multiple scope?? --- according to OAuth 2.0 playround, multiple scope is supposed. --- BS.intercalate "+" scopes)] **does not work** --- scopes = [googleScopeEmail, googleScopeUserInfo] **in order to get email** --- -loginWithGoogleH :: HasOAuth b => Handler b v () -loginWithGoogleH = loginWithOauthH Google scopeParam - where scopeParam = Just $ renderSimpleQuery False scopeQuery - scopeQuery = [(googleScopeKey, googleScopeUserInfo)] +-- | +googleLoginH :: HasOAuth b => Handler b v () +googleLoginH = loginWithOauthH google scopeParam + where scopeParam = Just $ renderSimpleQuery False scopeQuery + scopeQuery = [(googleScopeKey, BS.intercalate " " scopes)] + -- | multiple scope in order to get email info + scopes = [googleScopeEmail, googleScopeUserInfo] -googleCallbackH :: HasOAuth b => Handler b v OAuth2 -googleCallbackH = oauthCallbackH Google +googleCallbackH :: HasOAuth b => Handler b v OAuthValue +googleCallbackH = oauthCallbackH google -userInfoH :: HasOAuth b => OAuth2 -> Handler b v (Maybe GoogleUser) -userInfoH = liftIO . userInfo +googleUserH :: HasOAuth b => Handler b v (Maybe GoogleUser) +googleUserH = googleCallbackH + >>= liftIO . userInfo ------------------------------------------------------------------------------ -- | The application's routes. -- routes :: HasOAuth b => [(ByteString, Handler b v ())] -routes = [ ("/google", loginWithGoogleH) +routes = [ ("/google", googleLoginH) ] diff --git a/src/Snap/Snaplet/OAuth/Google/Api.hs b/src/Snap/Snaplet/OAuth/Google/Api.hs --- a/src/Snap/Snaplet/OAuth/Google/Api.hs +++ b/src/Snap/Snaplet/OAuth/Google/Api.hs @@ -18,7 +18,7 @@ import qualified Data.ByteString as BS import Data.Text (Text) -import Network.OAuth2.OAuth2 +import Snap.Snaplet.OAuth.Internal.Types import Snap.Snaplet.OAuth.Internal.Utils @@ -26,9 +26,10 @@ -- APIs Impl ---------------------------------------------------------------------- -data GoogleUser = GoogleUser { gid :: Text - , gname :: Text - , glink :: Text +data GoogleUser = GoogleUser { gid :: Text + , gname :: Text + , glink :: Text + , gemail :: Text } deriving (Show, Eq) instance FromJSON GoogleUser where @@ -36,6 +37,7 @@ <$> o .: "id" <*> o .: "name" <*> o .: "link" + <*> o .: "email" parseJSON _ = mzero ---------------------------------------------------------------------- @@ -43,7 +45,7 @@ ---------------------------------------------------------------------- -userInfo :: OAuth2 -> IO (Maybe GoogleUser) +userInfo :: OAuthValue -> IO (Maybe GoogleUser) userInfo = apiRequestOAuth uriUserInfor diff --git a/src/Snap/Snaplet/OAuth/Internal/Handlers.hs b/src/Snap/Snaplet/OAuth/Internal/Handlers.hs --- a/src/Snap/Snaplet/OAuth/Internal/Handlers.hs +++ b/src/Snap/Snaplet/OAuth/Internal/Handlers.hs @@ -7,8 +7,8 @@ import Control.Monad.CatchIO (throw) import qualified Data.ByteString as BS import Data.Maybe -import Network.OAuth2.HTTP.HttpClient -import Network.OAuth2.OAuth2 +import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.HttpClient import Prelude hiding ((.)) import Snap @@ -35,7 +35,7 @@ -- oauthCallbackH :: HasOAuth b => OAuthKey - -> Handler b v OAuth2 + -> Handler b v OAuthValue oauthCallbackH key = withOAuthH key fn where fn oauth = do codeParam <- decodedParam accessTokenKey @@ -55,6 +55,8 @@ ---------------------------------------------------------------------- +-- | Perform an action with a full initilized @OAuth2@. +-- withOAuthH :: HasOAuth b => OAuthKey -> (OAuthValue -> Handler b v a) diff --git a/src/Snap/Snaplet/OAuth/Internal/Types.hs b/src/Snap/Snaplet/OAuth/Internal/Types.hs --- a/src/Snap/Snaplet/OAuth/Internal/Types.hs +++ b/src/Snap/Snaplet/OAuth/Internal/Types.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.OAuth.Internal.Types where +import Data.Hashable (Hashable (..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M import Data.Lens.Common -import Network.OAuth2.OAuth2 ---import Prelude hiding ((.)) -import Data.Hashable (Hashable (..)) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as M +import Network.OAuth.OAuth2 import Snap -import Snap.Snaplet.OAuth.Internal.Utils ---------------------------------------------------------------------- -- Snaplet @@ -54,10 +53,15 @@ newtype OAuthMap = OAuthMap (HashMap OAuthKey OAuthValue) +newtype OAuthKey = OAuthKey { unkey :: String } + deriving (Hashable, Eq) + type OAuthValue = OAuth2 -data OAuthKey = Google | Github | Twitter | Facebook | Weibo | QQ - deriving (Show, Eq, Enum) +google, github, weibo :: OAuthKey +google = OAuthKey "google" +github = OAuthKey "github" +weibo = OAuthKey "weibo" -instance Hashable OAuthKey where - hash = hash . sToBS . show +instance Show OAuthKey where + show = unkey diff --git a/src/Snap/Snaplet/OAuth/Internal/Utils.hs b/src/Snap/Snaplet/OAuth/Internal/Utils.hs --- a/src/Snap/Snaplet/OAuth/Internal/Utils.hs +++ b/src/Snap/Snaplet/OAuth/Internal/Utils.hs @@ -4,16 +4,15 @@ import Control.Applicative import Data.Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Network.OAuth2.HTTP.HttpClient -import Network.OAuth2.OAuth2 -import Snap hiding (Response) -import qualified Text.Show.ByteString as TSB +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.HttpClient +import Snap hiding (Response) +import qualified Text.Show.ByteString as TSB ---------------------------------------------------------------------- @@ -44,9 +43,4 @@ => BS.ByteString -- ^ API URL -> OAuth2 -- ^ For append access token -> IO (Maybe a) -apiRequestOAuth uri oa = apiRequest $ appendAccessToken uri oa - -apiRequest :: FromJSON a - => BS.ByteString -- ^ Full API URL - -> IO (Maybe a) -apiRequest = doJSONGetRequest . BS8.unpack +apiRequestOAuth uri oa = doJSONGetRequest $ appendAccessToken uri oa diff --git a/src/Snap/Snaplet/OAuth/Weibo.hs b/src/Snap/Snaplet/OAuth/Weibo.hs --- a/src/Snap/Snaplet/OAuth/Weibo.hs +++ b/src/Snap/Snaplet/OAuth/Weibo.hs @@ -2,11 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.OAuth.Weibo - ( routes - , loginWithWeiboH + ( -- * Routes + routes + -- * Handlers + , weiboLoginH , weiboCallbackH - , userIdH - , accountShowH + , weiboUserIdH + , weiboUserH + -- * Types and API , module Snap.Snaplet.OAuth.Weibo.Api ) where @@ -15,7 +18,6 @@ import Control.Monad import Data.ByteString (ByteString) import Data.Maybe -import Network.OAuth2.OAuth2 import Prelude hiding ((.)) import Snap @@ -27,38 +29,39 @@ -- Weibo ------------------------------------------------------------------------------ -loginWithWeiboH :: HasOAuth b => Handler b v () -loginWithWeiboH = loginWithOauthH Weibo Nothing +weiboLoginH :: HasOAuth b => Handler b v () +weiboLoginH = loginWithOauthH weibo Nothing -- | token access callback. --- return a @OAuth2@ having access token has been filled. +-- return a @OAuthValue@ having access token has been filled. -- -weiboCallbackH :: HasOAuth b => Handler b v OAuth2 -weiboCallbackH = oauthCallbackH Weibo +weiboCallbackH :: HasOAuth b => Handler b v OAuthValue +weiboCallbackH = oauthCallbackH weibo -- | userID is must for access other datas. -- -userIdH :: HasOAuth b => OAuth2 -> Handler b v (Maybe WeiboUserId) -userIdH = liftIO . requestUid +weiboUserIdH :: HasOAuth b => Handler b v (OAuthValue, Maybe WeiboUserId) +weiboUserIdH = do + oauth <- weiboCallbackH + uid <- liftIO $ requestUid oauth + return (oauth, uid) --- | Show Account detail info. + +-- | fetch weibo user info. -- -accountShowH :: HasOAuth b - => (Maybe WeiboUser -> Handler b v ()) - -> OAuth2 - -> Handler b v () -accountShowH fn oauth = - userIdH oauth >>= maybe failure success - where success uid = liftIO (requestAccount oauth uid) >>= fn - failure = writeBS "Failed at getting UID." +weiboUserH :: HasOAuth b => Handler b v (Maybe WeiboUser) +weiboUserH = do + (oauth, uid) <- weiboUserIdH + maybe failure (liftIO . requestAccount oauth) uid + where failure = return Nothing ------------------------------------------------------------------------------ -- | The application's routes. routes :: HasOAuth b => [(ByteString, Handler b v ())] -routes = [ ("/weibo" , loginWithWeiboH) +routes = [ ("/weibo" , weiboLoginH) ] diff --git a/src/Snap/Snaplet/OAuth/Weibo/Api.hs b/src/Snap/Snaplet/OAuth/Weibo/Api.hs --- a/src/Snap/Snaplet/OAuth/Weibo/Api.hs +++ b/src/Snap/Snaplet/OAuth/Weibo/Api.hs @@ -7,9 +7,11 @@ import qualified Data.ByteString as BS import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Network.HTTP.Types as HT -import Network.OAuth2.OAuth2 +--import qualified Network.HTTP.Types as HT +import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2.HttpClient import Snap +import Snap.Snaplet.OAuth.Internal.Types import Snap.Snaplet.OAuth.Internal.Utils ---------------------------------------------------------------------- @@ -20,10 +22,10 @@ -- FIXME: chinese name doest display correctly data WeiboUserId = WeiboUserId { weiboUserId :: Integer } deriving (Show, Eq) -data WeiboUser = WeiboUser { wUidStr :: Text - , wScreenNname :: Text - , wName :: Text - , wUrl :: Text +data WeiboUser = WeiboUser { wUidStr :: Text + , wScreenName :: Text + , wName :: Text + , wUrl :: Text } deriving (Show) -- | Parse UID response -- @@ -46,16 +48,15 @@ -- | User ID -- -requestUid :: OAuth2 -> IO (Maybe WeiboUserId) +requestUid :: OAuthValue -> IO (Maybe WeiboUserId) requestUid = apiRequestOAuth accountUidUri -- | User Info -- -requestAccount :: OAuth2 -> WeiboUserId -> IO (Maybe WeiboUser) -requestAccount oa uid = apiRequest uri - where uri = accountShowUri `BS.append` query - query = HT.renderSimpleQuery True params +requestAccount :: OAuthValue -> WeiboUserId -> IO (Maybe WeiboUser) +requestAccount oa uid = doJSONGetRequest uri + where uri = appendQueryParam accountShowUri params params = accessTokenToParam token ++ uidToParam uid token = fromMaybe "" (oauthAccessToken oa) @@ -72,4 +73,3 @@ accountShowUri :: BS.ByteString accountShowUri = sToBS "https://api.weibo.com/2/users/show.json" - diff --git a/tests/Weibo.hs b/tests/Weibo.hs new file mode 100644 --- /dev/null +++ b/tests/Weibo.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Weibo where + +import Data.Aeson (decode) +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Maybe (fromJust, isJust) +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?), (@?=)) + +import Snap.Snaplet.OAuth.Weibo + + +uidTests :: Test +uidTests = testGroup "uid test cases" + [ testCase "uid shall be 12345" $ getUid @?= Just aOid + , testCase "uid shall be 2709495807" $ getUid2 @?= Just aOid2 + , testCase "uid shall be any number" $ isJust getUid @? "uid any number test" + , testCase "uid is not string" $ getInvalidUid @?= Nothing + , testCase "uidstr is string" $ getIdStr @?= "1814581760" + , testCase "uidstr is string" $ getNameStr @?= "HaishengWoo" + ] + +------------------------------------------------ + +invalidUidString :: BSL.ByteString +invalidUidString = "{\"uid\" : \"12345\" }" + +getInvalidUid :: Maybe WeiboUserId +getInvalidUid = decode invalidUidString + +------------------------------------------------ + +aOid :: WeiboUserId +aOid = WeiboUserId 12345 + +getUid :: Maybe WeiboUserId +getUid = decode ("{\"uid\" : 12345 }" :: BSL.ByteString) + + +aOid2 = WeiboUserId 2709495807123 +getUid2 = decode ("{\"uid\" : 2709495807123 }" :: BSL.ByteString) + +------------------------------------------------ +getIdStr = wUidStr $ fromJust userInfo +getNameStr = wName $ fromJust userInfo + +userInfo :: Maybe WeiboUser +userInfo = decode userInfoStr + +userInfoStr :: BSL.ByteString +userInfoStr = BSL.pack "{\"id\": 1814581760, \"idstr\": \"1814581760\", \"screen_name\": \"HaishengWoo\", \"name\": \"HaishengWoo\", \"url\": \"http://freizl.github.com/\" }"