packages feed

snaplet-oauth (empty) → 0.0.5

raw patch · 12 files changed

+618/−0 lines, 12 filesdep +HUnitdep +MonadCatchIO-mtldep +aesonsetup-changed

Dependencies added: HUnit, MonadCatchIO-mtl, aeson, base, bytestring, bytestring-show, data-lens, data-lens-template, failure, hashable, heist, hoauth2, http-conduit, http-types, snap, snap-core, snap-loader-dynamic, snap-loader-static, snaplet-oauth, test-framework, test-framework-hunit, text, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Haisheng,Wu++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.++    * Neither the name of Haisheng,Wu nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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+OWNER OR CONTRIBUTORS 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.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ snaplet-oauth.cabal view
@@ -0,0 +1,82 @@++Name:                snaplet-oauth+Version:             0.0.5+Synopsis:            snaplet-oauth+Description:         This lib is in Alpha status and APIs are likely to be changed.+Homepage:            freizl.github.com+License:             BSD3+License-file:        LICENSE+Author:              Haisheng,Wu+Maintainer:          freizl@gmail.com+Copyright:           Haisheng,Wu+Category:            Web+Build-type:          Simple+stability:           alpha++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files:  ++Cabal-version:       >=1.10++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++  Other-Modules:+      Snap.Snaplet.OAuth.Weibo.Api+      Snap.Snaplet.OAuth.Google.Api++  Build-Depends:    +      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.*,+      failure              >= 0.1,+      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+++  if impl(ghc >= 6.12.0)+      ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+                   -fno-warn-orphans -fno-warn-unused-do-bind+  else+      ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+                   -fno-warn-orphans     ++Test-suite oauth-unit-tests+  Type:           exitcode-stdio-1.0+  Hs-source-dirs: tests+  Main-is:        tests.hs+  Ghc-options:    -Wall+  default-language:  Haskell2010+  Build-depends:+    -- Copied from regular dependencies:+    HUnit                >= 1.2  && < 1.3,+    aeson                >= 0.6  && < 0.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,+    text                 >= 0.11 && < 0.12,+    snaplet-oauth        >= 0.0.5 && < 0.0.6
+ src/Snap/Snaplet/OAuth.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.OAuth+       ( initOauthSnaplet+       , module OA+       , module HS+       , module UT+       , module TY ) where++import           Data.ByteString                      (ByteString)+import           Snap++import           Network.OAuth2.OAuth2                as OA+import qualified Snap.Snaplet.OAuth.Google            as G+import           Snap.Snaplet.OAuth.Internal.Handlers as HS+import           Snap.Snaplet.OAuth.Internal.Types    as TY+import           Snap.Snaplet.OAuth.Internal.Utils    as UT+import qualified Snap.Snaplet.OAuth.Weibo             as W++-------------------------------------------------------++-- | Init this OAuthSnaplet snaplet.+--+initOauthSnaplet :: HasOAuth b+                    => Bool+                    -- ^ Add default routes or not+                    -> OAuthMap+                    -- ^ Oauth Keys+                    -> SnapletInit b OAuthSnaplet+initOauthSnaplet rt oauths =+    makeSnaplet "OAuthSnaplet" "" Nothing $ do+        when rt (addRoutes routes)+        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
+ src/Snap/Snaplet/OAuth/Google.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}++module Snap.Snaplet.OAuth.Google+       ( routes+       , loginWithGoogleH+       , googleCallbackH+       , userInfoH+       , module Snap.Snaplet.OAuth.Google.Api+       ) where++------------------------------------------------------------------------------+import           Control.Category+import           Data.ByteString                      (ByteString)+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++------------------------------------------------------------------------------+--              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)]+++googleCallbackH :: HasOAuth b => Handler b v OAuth2+googleCallbackH = oauthCallbackH Google+++userInfoH :: HasOAuth b => OAuth2 -> Handler b v (Maybe GoogleUser)+userInfoH = liftIO . userInfo++------------------------------------------------------------------------------++-- | The application's routes.+--+routes :: HasOAuth b => [(ByteString, Handler b v ())]+routes  = [ ("/google", loginWithGoogleH)+          ]
+ src/Snap/Snaplet/OAuth/Google/Api.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++{-++This is basically very manual test. Check following link for details.++google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer++Google OAuth 2.0 playround: https://developers.google.com/oauthplayground/++-}++module Snap.Snaplet.OAuth.Google.Api where++import           Control.Applicative+import           Control.Monad                     (mzero)+import           Data.Aeson+import qualified Data.ByteString                   as BS+import           Data.Text                         (Text)++import           Network.OAuth2.OAuth2+import           Snap.Snaplet.OAuth.Internal.Utils+++----------------------------------------------------------------------+--  APIs Impl+----------------------------------------------------------------------++data GoogleUser = GoogleUser { gid   :: Text+                             , gname :: Text+                             , glink :: Text+                             } deriving (Show, Eq)++instance FromJSON GoogleUser where+    parseJSON (Object o) = GoogleUser+                           <$> o .: "id"+                           <*> o .: "name"+                           <*> o .: "link"+    parseJSON _ = mzero++----------------------------------------------------------------------+--  APIs Impl+----------------------------------------------------------------------+++userInfo :: OAuth2 -> IO (Maybe GoogleUser)+userInfo = apiRequestOAuth uriUserInfor++++----------------------------------------------------------------------+--  APIs URI+----------------------------------------------------------------------++googleScopeKey :: BS.ByteString+googleScopeKey = "scope"++-- | this is special for google Gain read-only access to the user's email address.+googleScopeEmail :: BS.ByteString+googleScopeEmail = "https://www.googleapis.com/auth/userinfo.email"++-- | Gain read-only access to basic profile information.+googleScopeUserInfo :: BS.ByteString+googleScopeUserInfo = "https://www.googleapis.com/auth/userinfo.profile"++-- | Possible operations of UserInfo+--+uriUserInfor :: BS.ByteString+uriUserInfor = "https://www.googleapis.com/oauth2/v2/userinfo"
+ src/Snap/Snaplet/OAuth/Internal/Handlers.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.OAuth.Internal.Handlers+       ( loginWithOauthH+       , oauthCallbackH ) where++import           Control.Monad.CatchIO             (throw)+import qualified Data.ByteString                   as BS+import           Data.Maybe+import           Network.OAuth2.HTTP.HttpClient+import           Network.OAuth2.OAuth2+import           Prelude                           hiding ((.))+import           Snap++import           Snap.Snaplet.OAuth.Internal.Types+import           Snap.Snaplet.OAuth.Internal.Utils++----------------------------------------------------------------------++-- | Login via OAuth. Redirect user for authorization.+--+loginWithOauthH :: HasOAuth b+               => OAuthKey+               -> Maybe BS.ByteString+               -- ^ Maybe extra query parameters,e.g., 'scope' param for google oauth.+               -> Handler b v ()+loginWithOauthH key param = withOAuthH key fn+    where extraP (Just x) = "&" `BS.append` x+          extraP Nothing  = ""+          fn oauth = redirect $ authorizationUrl oauth `BS.append` extraP param++----------------------------------------------------------------------++-- | Callback for oauth provider.+--+oauthCallbackH :: HasOAuth b+                  => OAuthKey+                  -> Handler b v OAuth2+oauthCallbackH key = withOAuthH key fn+    where fn oauth = do+                     codeParam  <- decodedParam accessTokenKey+                     maybeToken <- liftIO $ requestAccessToken oauth codeParam+                     case maybeToken of+                         Just token -> liftIO $ modifyAccessToken token oauth+                         _ -> throw (OAuthException $ "Failed to request Access Token." ++ show key)+                              >> return oauth+++modifyAccessToken :: AccessToken -> OAuth2 -> IO OAuth2+modifyAccessToken (AccessToken at _) origin = return $ origin { oauthAccessToken = Just at }+++accessTokenKey :: BS.ByteString+accessTokenKey = "code"++----------------------------------------------------------------------++withOAuthH :: HasOAuth b+              => OAuthKey+              -> (OAuthValue -> Handler b v a)+              -> Handler b v a+withOAuthH key fn = do+    value <- lookupOAuth key+    case value of+      Nothing -> failure+      Just oauth -> fn oauth+    where failure = throw $ OAuthException $ "oauth data has not been init of: " ++ show key+++-- checkLogin :: HasOAuth b => OAuth2 -> Handler b v ()+-- checkLogin oa = when (isNothing $ oauthAccessToken oa) $ redirect "weibo"+
+ src/Snap/Snaplet/OAuth/Internal/Types.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.OAuth.Internal.Types where++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           Snap+import           Snap.Snaplet.OAuth.Internal.Utils++----------------------------------------------------------------------+-- Snaplet+----------------------------------------------------------------------++-- |+--+data OAuthSnaplet = OAuthSnaplet { oauthKeys :: OAuthMap }++emptyOAuthSnaplet :: OAuthSnaplet+emptyOAuthSnaplet = OAuthSnaplet (OAuthMap M.empty)++-- | TODO: just define `getOauthSnaplet` without oauthLens+--+-- | Some snaplet implementation just define a get function is because is read only snaplet.+--   Therefore, the get function could be like+--   `getXXX = with oauth Snap.get`+--   where the `oauth` here can be found at `data App = App { _oauth : xxxx, ....}+--+class HasOAuth b where+  oauthLens :: Lens b (Snaplet OAuthSnaplet)+++getOauthSnaplet :: HasOAuth b => Handler b v OAuthSnaplet+getOauthSnaplet = withTop oauthLens Snap.get+++getOauthKeys :: HasOAuth b => Handler b v OAuthMap+getOauthKeys = liftM oauthKeys getOauthSnaplet+++lookupOAuth :: HasOAuth b => OAuthKey -> Handler b v (Maybe OAuthValue)+lookupOAuth name = do+    (OAuthMap keys) <- getOauthKeys+    return $ M.lookup name keys+++----------------------------------------------------------------------+-- OAuth Keys+----------------------------------------------------------------------+++newtype OAuthMap = OAuthMap (HashMap OAuthKey OAuthValue)++type OAuthValue = OAuth2++data OAuthKey = Google | Github | Twitter | Facebook | Weibo | QQ+                deriving (Show, Eq, Enum)++instance Hashable OAuthKey where+  hash = hash . sToBS . show
+ src/Snap/Snaplet/OAuth/Internal/Utils.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.OAuth.Internal.Utils where++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++----------------------------------------------------------------------++intToByteString :: Integer -> BS.ByteString+intToByteString = toStrickBS' . TSB.show++sToText :: Show s => s -> T.Text+sToText = T.pack . show++toStrickBS' :: LBS.ByteString -> BS.ByteString+toStrickBS' = BS.concat . LBS.toChunks++sToBS :: String -> BS.ByteString+sToBS = T.encodeUtf8 . T.pack++lbsToText :: LBS.ByteString -> T.Text+lbsToText = T.decodeUtf8 . toStrickBS'++textToBS :: T.Text -> BS.ByteString+textToBS = T.encodeUtf8++decodedParam :: MonadSnap m => BS.ByteString -> m BS.ByteString+decodedParam p = fromMaybe "" <$> getParam p++----------------------------------------------------------------------++apiRequestOAuth :: FromJSON a+              => 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
+ src/Snap/Snaplet/OAuth/Weibo.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.OAuth.Weibo+       ( routes+       , loginWithWeiboH+       , weiboCallbackH+       , userIdH+       , accountShowH+       , module Snap.Snaplet.OAuth.Weibo.Api+       ) where++------------------------------------------------------------------------------+import           Control.Category+import           Control.Monad+import           Data.ByteString                      (ByteString)+import           Data.Maybe+import           Network.OAuth2.OAuth2+import           Prelude                              hiding ((.))+import           Snap++import           Snap.Snaplet.OAuth.Internal.Handlers+import           Snap.Snaplet.OAuth.Internal.Types+import           Snap.Snaplet.OAuth.Weibo.Api++------------------------------------------------------------------------------+--              Weibo+------------------------------------------------------------------------------++loginWithWeiboH :: HasOAuth b => Handler b v ()+loginWithWeiboH = loginWithOauthH Weibo Nothing+++-- | token access callback.+--   return a @OAuth2@ having access token has been filled.+--+weiboCallbackH :: HasOAuth b => Handler b v OAuth2+weiboCallbackH = oauthCallbackH Weibo++-- | userID is must for access other datas.+--+userIdH :: HasOAuth b => OAuth2 -> Handler b v (Maybe WeiboUserId)+userIdH = liftIO . requestUid++-- | Show Account detail 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."+++------------------------------------------------------------------------------++-- | The application's routes.+routes :: HasOAuth b => [(ByteString, Handler b v ())]+routes  = [ ("/weibo" , loginWithWeiboH)+          ]+++----------------------------------------------------------------------------
+ src/Snap/Snaplet/OAuth/Weibo/Api.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+++module Snap.Snaplet.OAuth.Weibo.Api where++import           Data.Aeson+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           Snap+import           Snap.Snaplet.OAuth.Internal.Utils++----------------------------------------------------------------------+--  Weibo User ID+----------------------------------------------------------------------++-- | UID data type+--   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+                           } deriving (Show)+-- | Parse UID response+--+instance FromJSON WeiboUserId where+    parseJSON (Object o) = WeiboUserId <$> o .: "uid"+    parseJSON _ = mzero++instance FromJSON WeiboUser where+    parseJSON (Object o) = WeiboUser+                          <$> o .: "idstr"+                          <*> o .: "screen_name"+                          <*> o .: "name"+                          <*> o .: "url"+    parseJSON _ = mzero+++----------------------------------------------------------------------+--  API Impl+----------------------------------------------------------------------++-- | User ID+--+requestUid :: OAuth2 -> 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+          params = accessTokenToParam token ++ uidToParam uid+          token = fromMaybe "" (oauthAccessToken oa)++uidToParam :: WeiboUserId -> [(BS.ByteString, BS.ByteString)]+uidToParam (WeiboUserId uid) = [("uid", intToByteString uid)]+++----------------------------------------------------------------------+--  API URI+----------------------------------------------------------------------++accountUidUri :: BS.ByteString+accountUidUri = sToBS "https://api.weibo.com/2/account/get_uid.json"++accountShowUri :: BS.ByteString+accountShowUri = sToBS "https://api.weibo.com/2/users/show.json"+
+ tests/tests.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}++import           Test.Framework (defaultMain)++import qualified Weibo          as W++main :: IO ()+main = testSuits++testSuits :: IO ()+testSuits = defaultMain+            [ W.uidTests+            ]