Skip to content
Browse files

use MVar to share single AccessToken

  • Loading branch information...
1 parent 073ca7f commit 5463cb134a9eeedbfd40d50e32a6bc877d77fe60 @freizl freizl committed May 11, 2012
Showing with 138 additions and 91 deletions.
  1. +1 −1 snaplet-oauth.cabal
  2. +68 −42 src/Snap/Snaplet/OAuth.hs
  3. +34 −21 test/Api.hs
  4. +11 −1 test/Utils.hs
  5. +24 −26 test/snap.hs
View
2 snaplet-oauth.cabal
@@ -2,7 +2,7 @@
Name: snaplet-oauth
Version: 0.0.2
Synopsis: snaplet-oauth
--- Description:
+Description: This lib is in Alpha status and APIs are likely to be changed.
Homepage: freizl.github.com
License: BSD3
License-file: LICENSE
View
110 src/Snap/Snaplet/OAuth.hs
@@ -2,31 +2,35 @@
module Snap.Snaplet.OAuth where
-import Control.Applicative
-import Data.Lens.Common
-import Data.Maybe
-import Network.OAuth2.HTTP.HttpClient
-import Network.OAuth2.OAuth2
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BS8
-import Prelude hiding ((.))
+import Control.Applicative
import Control.Category
+import Control.Concurrent.MVar
+import Data.Lens.Common
+import Data.Maybe
+import Network.OAuth2.HTTP.HttpClient
+import Network.OAuth2.OAuth2
+import Prelude hiding ((.))
+
+import qualified Data.ByteString as BS
import Snap
-------------------------------------------------------
-- TODO
--
--- 1. could be multiple oauth impl in one app.
+-- 1. Shoule be able to do
+-- - allow multiple user login with various OAuth provider, e.g. Weibo/Google
-------------------------------------------------------
+-- |
+-- FIXME: further, the OAuth2 should be a Map since accessToken is vary among users.
--
data OAuthSnaplet = OAuthSnaplet
- { getOauth :: OAuth2 -- ^ This is major oauth related data
+ { getOauth :: MVar OAuth2 -- ^ This is major oauth related data
, getCodeParam :: BS.ByteString -- ^ query param that oauth provider will use at callback url.
- } deriving (Show) -- ^ e.g. localhost/oauthCallback?code=123, so pick up 'code'.
+ } -- ^ e.g. localhost/oauthCallback?code=123, so pick up 'code'.
-- | TODO: just define `getOauthSnaplet` without oauthLens
--
@@ -36,30 +40,46 @@ data OAuthSnaplet = OAuthSnaplet
-- where the `oauth` here can be found at `data App = App { _oauth : xxxx, ....}
--
class HasOauth b where
- oauthLens' :: Lens b (Snaplet OAuthSnaplet)
- oauthLens :: Lens (Snaplet b) (Snaplet OAuthSnaplet)
+ oauthLens :: Lens b (Snaplet OAuthSnaplet)
- getOauthSnaplet :: Handler b b OAuthSnaplet
- getOauthSnaplet = with' oauthLens Snap.get
+ oauthLens' :: Lens (Snaplet b) (Snaplet OAuthSnaplet)
+ oauthLens' = subSnaplet oauthLens
- updateOAuthSnaplet :: (MonadSnaplet m) => m b OAuthSnaplet a -> m b b a
- updateOAuthSnaplet = with' oauthLens
+
+ --updateOAuthSnaplet :: (MonadSnaplet m) => m b OAuthSnaplet a -> m b b a
+ --updateOAuthSnaplet = with oauthLens
+
+getOauthSnaplet :: HasOauth b => Handler b b OAuthSnaplet
+getOauthSnaplet = with oauthLens Snap.get
+
+readOAuthMVar' :: HasOauth b => OAuthSnaplet -> Handler b b OAuth2
+readOAuthMVar' = liftIO . readMVar . getOauth
+
+readOAuthMVar :: HasOauth b => Handler b b OAuth2
+readOAuthMVar = getOauthSnaplet >>= readOAuthMVar'
-------------------------------------------------------
-- | Init this OAuthSnaplet snaplet.
--
-initOauthSnaplet :: OAuth2 -> BS.ByteString -> SnapletInit b OAuthSnaplet
+initOauthSnaplet :: OAuth2 -> Maybe BS.ByteString -> SnapletInit b OAuthSnaplet
initOauthSnaplet oauth param
= makeSnaplet "OAuthSnaplet" "" Nothing $
- if (isOauthDataInit oauth) -- FIXME: && (not . BS.null param)
- then return $ OAuthSnaplet oauth param
+ if (isOauthDataInit oauth) then do
+ mo <- liftIO $ newMVar oauth
+ return $ OAuthSnaplet mo (defaultParam param)
else fail "OAuthSnaplet is not initlized correctly. Please check."
+ where
+ defaultParam :: Maybe BS.ByteString -> BS.ByteString
+ defaultParam Nothing = "code"
+ defaultParam (Just "") = "code"
+ defaultParam (Just x) = x
isOauthDataInit :: OAuth2 -> Bool
-isOauthDataInit o = foldr (\ f b -> (not . BS.null $ f o) && b) True [ oauthClientId, oauthClientSecret ,
- oauthOAuthorizeEndpoint ,
- oauthAccessTokenEndpoint ]
+isOauthDataInit o = foldr (\ f b -> (not . BS.null $ f o) && b) True [ oauthClientId,
+ oauthClientSecret ,
+ oauthOAuthorizeEndpoint ,
+ oauthAccessTokenEndpoint ]
-------------------------------------------------------
-- Handlers
@@ -68,11 +88,11 @@ isOauthDataInit o = foldr (\ f b -> (not . BS.null $ f o) && b) True [ oauthClie
-- | Login via OAuth. Redirect user for authorization.
--
loginWithOauth :: HasOauth b
- => Maybe BS.ByteString -- ^ Maybe extra query parameters
+ => Maybe BS.ByteString -- ^ Maybe extra query parameters,e.g., 'scope' param for google oauth.
-> Handler b b ()
loginWithOauth param = do
- oauthSnaplet <- getOauthSnaplet
- redirect $ (authorizationUrl $ getOauth oauthSnaplet) `BS.append` extraP param
+ oauth <- readOAuthMVar
+ redirect $ (authorizationUrl oauth ) `BS.append` extraP param
where extraP (Just x) = "&" `BS.append` x
extraP Nothing = ""
@@ -84,31 +104,37 @@ oauthCallbackHandler :: HasOauth b
-> Handler b b ()
oauthCallbackHandler uri = do
oauthSnaplet <- getOauthSnaplet
- code <- decodedParam' (getCodeParam oauthSnaplet)
- maybeToken <- liftIO $ requestAccessToken (getOauth oauthSnaplet) code
- liftIO $ print uri
+ codeParam <- decodedParam' (getCodeParam oauthSnaplet)
+ oauth <- readOAuthMVar' oauthSnaplet
+ maybeToken <- liftIO $ requestAccessToken oauth codeParam
case maybeToken of
Just token -> do
- updateOAuthSnaplet (modify $ modifyOAuthState token)
- ss <- getOauthSnaplet
- writeBS $ BS8.pack (show $ getOauth ss)
- -- redirect $ fromMaybe "/" uri
+ liftIO $ modifyOAuthState token oauthSnaplet
+ redirect $ fromMaybe "/" uri
_ -> writeBS "Error getting access token."
---modify2 token
-modify2 :: (MonadIO m, MonadState b m, HasOauth b) => AccessToken -> m ()
-modify2 token = modify (modL (snapletValue . oauthLens') (modifyOAuthState token))
-
-------------------------------------------------------
--- | Update AccessToken after fetched.
-modifyOAuthState :: AccessToken -> OAuthSnaplet -> OAuthSnaplet
-modifyOAuthState (AccessToken at) oa = OAuthSnaplet { getOauth = newOA, getCodeParam = getCodeParam oa }
- where newOA = originOA { oauthAccessToken = Just at }
- originOA = getOauth oa
+
+modifyOAuthState :: AccessToken -> OAuthSnaplet -> IO ()
+modifyOAuthState at os = modifyMVar_ (getOauth os) (modifyAccessToken at)
+
+modifyAccessToken :: AccessToken -> OAuth2 -> IO OAuth2
+modifyAccessToken (AccessToken at) origin = return $ origin { oauthAccessToken = Just at }
+
decodedParam' :: MonadSnap m => BS.ByteString -> m BS.ByteString
decodedParam' p = fromMaybe "" <$> getParam p
-------------------------------------------------------
+
+-- | Update AccessToken after fetched.
+--modifyOAuthState' :: AccessToken -> OAuthSnaplet -> OAuthSnaplet
+--modifyOAuthState' (AccessToken at) oa = OAuthSnaplet { getOauth = newOA, getCodeParam = getCodeParam oa }
+-- where newOA = originOA { oauthAccessToken = Just at }
+-- originOA = getOauth oa
+
+--modify2 token
+--modify2 :: (MonadIO m, MonadState b m, HasOauth b) => AccessToken -> m ()
+--modify2 token = modify (modL (snapletValue . oauthLens') (modifyOAuthState token))
View
55 test/Api.hs
@@ -7,7 +7,7 @@ import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as T
import qualified Data.Text as T
import Data.Aeson
---import qualified Data.ByteString as BS
+import Data.Maybe (fromMaybe, fromJust)
import Data.Typeable (Typeable)
import Network.HTTP.Types (renderSimpleQuery)
import Control.Exception
@@ -30,7 +30,8 @@ accountUidUri = pack' "https://api.weibo.com/2/account/get_uid.json"
accountShowUri :: BS.ByteString
accountShowUri = pack' "https://api.weibo.com/2/users/show.json"
-pack' = T.encodeUtf8 . T.pack
+---------------------------------------------------------------
+
-- | UID
@@ -40,30 +41,42 @@ instance FromJSON WeiboUserId where
parseJSON (Object o) = WeiboUserId <$> o .: "uid"
parseJSON _ = mzero
-apiUrlGet2 :: URI -- ^ Base URI
- -> (AccessToken, WeiboUserId) -- ^ Authorized Access Token and UID
- -> URI -- ^ Combined Result
+---------------------------------------------------------------
+
+-- | Fetch UID
+--
+requestUid :: OAuth2
+ -> IO (Maybe WeiboUserId)
+requestUid oa = decode <$> requestUid' accountUidUri oa
+
+requestUid' :: URI
+ -> OAuth2
+ -> IO BSL.ByteString
+requestUid' uri oa = doSimpleGetRequest (BS8.unpack $ appendAccessToken uri oa) >>= handleResponse
+
+---------------------------------------------------------------
+
+-- | Fetch User information
+requestAccount :: OAuth2 -> WeiboUserId -> IO BSL.ByteString
+requestAccount oa uid = doSimpleGetRequest (BS8.unpack $ apiUrlGet2 accountShowUri atid) >>= handleResponse
+ where atid = (fromJust $ oauthAccessToken oa, uid)
+
+
+---------------------------------------------------------------
+
+apiUrlGet2 :: URI -- ^ Base URI
+ -> (BS.ByteString, WeiboUserId) -- ^ Authorized Access Token and UID
+ -> URI -- ^ Combined Result
apiUrlGet2 uri (token, uid) = uri `BS.append` (renderSimpleQuery True $
(accessTokenToParam token ++ uidToParam uid))
+handleResponse :: Response BSL.ByteString -> IO BSL.ByteString
+handleResponse rsp = if (HT.statusCode . responseStatus) rsp == 200
+ then return $ responseBody rsp
+ else throwIO . OAuthException $ "Gaining uid failed: " ++ BSL.unpack (responseBody rsp)
+
uidToParam :: WeiboUserId -> [(BS.ByteString, BS.ByteString)]
uidToParam (WeiboUserId uid) = [("uid", intToByteString uid)]
--- | Fetch UID
---
-requestUid :: URI -- ^ Fetch UID API URI
- -> AccessToken
- -> IO (Maybe WeiboUserId)
-requestUid uri token = decode <$> requestUid' uri token
-
-requestUid' :: URI
- -> AccessToken
- -> IO BSL.ByteString
-requestUid' uri token = doSimpleGetRequest (BS8.unpack $ apiUrlGet uri token) >>= retOrError
- where
- retOrError rsp = if (HT.statusCode . responseStatus) rsp == 200
- --then (print $ responseBody rsp) >> (return $ responseBody rsp)
- then return $ responseBody rsp
- else throwIO . OAuthException $ "Gaining uid failed: " ++ BSL.unpack (responseBody rsp)
View
12 test/Utils.hs
@@ -4,9 +4,19 @@ module Utils where
import qualified Text.Show.ByteString as TSB
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text.Encoding as T
+import qualified Data.Text as T
+
intToByteString :: Int -> BS.ByteString
intToByteString = toStrickBS' . TSB.show
toStrickBS' :: LBS.ByteString -> BS.ByteString
-toStrickBS' = BS.concat . LBS.toChunks
+toStrickBS' = BS.concat . LBS.toChunks
+
+pack' :: String -> BS.ByteString
+pack' = T.encodeUtf8 . T.pack
+
+
+lbsToText :: LBS.ByteString -> T.Text
+lbsToText = T.decodeUtf8 . toStrickBS'
View
50 test/snap.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RankNTypes #-}
{-
templates must follow a kind of scalfold
@@ -29,7 +29,6 @@ import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-import qualified Snap as Snap
#ifdef DEVELOPMENT
import Snap.Loader.Devel
@@ -42,13 +41,13 @@ import Network.OAuth2.HTTP.HttpClient
import Key
import Api
+import Utils
------------------------------------------------------------------------------
data App = App
{ _heist :: Snaplet (Heist App)
, _weibo :: Snaplet OAuthSnaplet
- , _google :: Snaplet OAuthSnaplet
}
makeLens ''App
@@ -58,8 +57,10 @@ instance HasHeist App where
-- | FIXME : how to allow multiple OAuthSnaplets ??
instance HasOauth App where
- oauthLens' = google
- oauthLens = subSnaplet google
+ oauthLens = weibo
+ --oauthLens' = google
+ --oauthLens = subSnaplet google
+
type AppHandler = Handler App App
@@ -85,44 +86,41 @@ loginWithWeibo :: Handler App App ()
loginWithWeibo = loginWithOauth Nothing
weiboCallback :: Handler App App ()
-weiboCallback = oauthCallbackHandler $ Just "/test"
+weiboCallback = oauthCallbackHandler $ Just "/accountShow"
-loginWithGoogle :: Handler App App ()
-loginWithGoogle = loginWithOauth $ Just googleScopeStr
-
-googleCallback :: Handler App App ()
-googleCallback = oauthCallbackHandler $ Just "/test"
+accountShow :: Handler App App ()
+accountShow = do
+ oauth <- readOAuthMVar
+ maybeUID <- liftIO $ requestUid oauth
+ case maybeUID of
+ Just uid -> (writeText . lbsToText) =<< liftIO (requestAccount oauth uid)
+ _ -> writeBS "Failed at getting UID."
test :: Handler App App ()
test = do
- ss <- getOauthSnaplet
- writeText $ T.pack (show $ getOauth ss)
-
--- | this is special for google.
-googleScopeStr = renderSimpleQuery False [("scope", "https://www.googleapis.com/auth/userinfo.email")]
+ ss <- readOAuthMVar
+ writeText $ T.pack (show ss)
------------------------------------------------------------------------------
-- | The application's routes.
routes :: [(ByteString, Handler App App ())]
routes = [ ("", with heist heistServe) -- ^ FIXME: maybe no need heist
- , ("/", writeBS "It works!<a href='/weibo'>login via weibo</a>, <a href='/google'>login via google</a>") -- FIXME: parseHTML
- , ("/weibo", loginWithWeibo)
- , ("/google", loginWithGoogle)
- , ("/oauthCallback", weiboCallback )
- , ("/googleCallback", googleCallback)
+ , ("/", writeBS "It works!<a href='/weibo'>login via weibo</a>") -- FIXME: parseHTML
+ , ("/weibo" , loginWithWeibo)
+ , ("/oauthCallback", weiboCallback)
+ , ("/accountShow" , accountShow)
, ("/test", test)
]
-- | The application initializer.
app :: SnapletInit App App
app = makeSnaplet "app" "An snaplet example application." Nothing $ do
h <- nestSnaplet "heist" heist $ heistInit "templates"
- w <- nestSnaplet "weiboOAuth" weibo $ initOauthSnaplet weiboOAuth "code"
- g <- nestSnaplet "googleOAuth" google $ initOauthSnaplet googleOAuth "code"
+ w <- nestSnaplet "weiboOAuth" weibo $ initOauthSnaplet weiboOAuth Nothing
addRoutes routes
- return $ App h w g
+ return $ App h w
------------------------------------------------------------------------------

0 comments on commit 5463cb1

Please sign in to comment.
Something went wrong with that request. Please try again.