packages feed

snaplet-oauth 0.0.5 → 0.0.6

raw patch · 30 files changed

+1031/−119 lines, 30 filesdep ~data-lensdep ~hoauth2dep ~http-conduit

Dependency ranges changed: data-lens, hoauth2, http-conduit, snaplet-oauth, test-framework, test-framework-hunit

Files

+ Makefile view
@@ -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
+ README.md view
@@ -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
+ example/Makefile view
@@ -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
+ example/example.cabal view
@@ -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
+ example/snaplets/heist/templates/_login.tpl view
@@ -0,0 +1,21 @@+<h1>Snap Example App Login</h1>++<p><loginError/></p>++<bind tag="postAction">/login</bind>+<bind tag="submitText">Login</bind>+<apply template="userform"/>++<p>Don't have a login yet? <a href="/new_user">Create a new user</a></p>+<ul>+  <li>+    <a href="/oauth/weibo">Login with Weibo</a>+  </li>+  <li>+    <a href="/oauth/google">Login with Google</a>+  </li>+  <li>+    <a href="/oauth/github">Login with Github</a>+  </li>+</ul>+
+ example/snaplets/heist/templates/_new_user.tpl view
@@ -0,0 +1,5 @@+<h1>Register a new user</h1>++<bind tag="postAction">/new_user</bind>+<bind tag="submitText">Add User</bind>+<apply template="userform"/>
+ example/snaplets/heist/templates/base.tpl view
@@ -0,0 +1,13 @@+<html>+  <head>+    <title>Snap web server</title>+    <link rel="stylesheet" type="text/css" href="/screen.css"/>+  </head>+  <body>+    <div id="content">++      <content/>++    </div>+  </body>+</html>
+ example/snaplets/heist/templates/index.tpl view
@@ -0,0 +1,22 @@+<apply template="base">++  <ifLoggedIn>+    <p>+      This is a simple demo page served using+      <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>+      and the <a href="http://snapframework.com/">Snap</a> web framework.+    </p>++    <p>Congrats!  You're logged in as '<loggedInUser/>'</p>+    <p><rawResponseSplices /></p>++    <p><a href="/">Home</a></p>+    <p><a href="/logout">Logout</a></p>++  </ifLoggedIn>++  <ifLoggedOut>+    <apply template="_login"/>+  </ifLoggedOut>++</apply>
+ example/snaplets/heist/templates/login.tpl view
@@ -0,0 +1,3 @@+<apply template="base">+  <apply template="_login"/>+</apply>
+ example/snaplets/heist/templates/new_user.tpl view
@@ -0,0 +1,3 @@+<apply template="base">+  <apply template="_new_user" />+</apply>
+ example/snaplets/heist/templates/userform.tpl view
@@ -0,0 +1,14 @@+<form method="post" action="${postAction}">+  <table id="info">+    <tr>+      <td>Login:</td><td><input type="text" name="login" size="20" /></td>+    </tr>+    <tr>+      <td>Password:</td><td><input type="password" name="password" size="20" /></td>+    </tr>+    <tr>+      <td></td>+      <td><input type="submit" value="${submitText}" /></td>+    </tr>+  </table>+</form>
+ example/src/Application.hs view
@@ -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++
+ example/src/Keys.hs.default view
@@ -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
+ example/src/Main.hs view
@@ -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)
+ example/src/OAuthHandlers.hs view
@@ -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"++----------------------------------------------------------------------+--+----------------------------------------------------------------------
+ example/src/Site.hs view
@@ -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
+ example/src/Splices.hs view
@@ -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)
+ example/static/screen.css view
@@ -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%;+}
snaplet-oauth.cabal view
@@ -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
src/Snap/Snaplet/OAuth.hs view
@@ -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)+                ]
+ src/Snap/Snaplet/OAuth/Github.hs view
@@ -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.+++----------------------------------------------------------------------------
+ src/Snap/Snaplet/OAuth/Github/Api.hs view
@@ -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"
src/Snap/Snaplet/OAuth/Google.hs view
@@ -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)           ]
src/Snap/Snaplet/OAuth/Google/Api.hs view
@@ -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
src/Snap/Snaplet/OAuth/Internal/Handlers.hs view
@@ -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)
src/Snap/Snaplet/OAuth/Internal/Types.hs view
@@ -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
src/Snap/Snaplet/OAuth/Internal/Utils.hs view
@@ -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
src/Snap/Snaplet/OAuth/Weibo.hs view
@@ -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)           ]
src/Snap/Snaplet/OAuth/Weibo/Api.hs view
@@ -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"-
+ tests/Weibo.hs view
@@ -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/\" }"