diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/snaplet-oauth.cabal b/snaplet-oauth.cabal new file mode 100644 --- /dev/null +++ b/snaplet-oauth.cabal @@ -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 diff --git a/src/Snap/Snaplet/OAuth.hs b/src/Snap/Snaplet/OAuth.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth.hs @@ -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 diff --git a/src/Snap/Snaplet/OAuth/Google.hs b/src/Snap/Snaplet/OAuth/Google.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Google.hs @@ -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) + ] diff --git a/src/Snap/Snaplet/OAuth/Google/Api.hs b/src/Snap/Snaplet/OAuth/Google/Api.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Google/Api.hs @@ -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" diff --git a/src/Snap/Snaplet/OAuth/Internal/Handlers.hs b/src/Snap/Snaplet/OAuth/Internal/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Internal/Handlers.hs @@ -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" + diff --git a/src/Snap/Snaplet/OAuth/Internal/Types.hs b/src/Snap/Snaplet/OAuth/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Internal/Types.hs @@ -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 diff --git a/src/Snap/Snaplet/OAuth/Internal/Utils.hs b/src/Snap/Snaplet/OAuth/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Internal/Utils.hs @@ -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 diff --git a/src/Snap/Snaplet/OAuth/Weibo.hs b/src/Snap/Snaplet/OAuth/Weibo.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Weibo.hs @@ -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) + ] + + +---------------------------------------------------------------------------- diff --git a/src/Snap/Snaplet/OAuth/Weibo/Api.hs b/src/Snap/Snaplet/OAuth/Weibo/Api.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/OAuth/Weibo/Api.hs @@ -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" + diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -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 + ]