Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 3 commits
  • 5 files changed
  • 0 comments
  • 1 contributor
10 README.md
Source Rendered
... ... @@ -1,4 +1,12 @@
1 1 snaplet-oauth
2 2 =============
3 3
4   -snaplet-oauth
  4 +snaplet-oauth
  5 +
  6 +
  7 +snaplet
  8 +=============
  9 +
  10 +- [what is snaplet]
  11 +
  12 +[what is snaplet]: http://snapframework.com/docs/tutorials/snaplets-tutorial
16 test/Key.hs.default
... ... @@ -0,0 +1,16 @@
  1 +{-# LANGUAGE OverloadedStrings #-}
  2 +
  3 +module Weibo.Key where
  4 +
  5 +import Network.OAuth2.OAuth2
  6 +
  7 +weiboKey :: OAuth2
  8 +weiboKey = OAuth2 { oauthClientId = "xxxxxxxxxxxx"
  9 + , oauthClientSecret = "xxxxxxxxxxxxx"
  10 + , oauthCallback = Just "http://MYHOST/someCallbackURL"
  11 + , oauthOAuthorizeEndpoint = ""
  12 + , oauthAccessTokenEndpoint = ""
  13 + , oauthAccessToken = Nothing
  14 + }
  15 +
  16 +
16 test/Api.hs → test/Weibo/Api.hs
... ... @@ -1,7 +1,7 @@
1 1 {-# LANGUAGE OverloadedStrings #-}
2 2
3 3
4   -module Api where
  4 +module Weibo.Api where
5 5
6 6 import qualified Data.ByteString as BS
7 7 import qualified Data.Text.Encoding as T
@@ -17,13 +17,17 @@ import Network.HTTP.Conduit
17 17 import qualified Data.ByteString.Char8 as BS8
18 18 import qualified Data.ByteString.Lazy.Char8 as BSL
19 19 import qualified Network.HTTP.Types as HT
20   -
  20 +import Control.Monad.Trans (liftIO)
  21 +import Control.Monad.IO.Class (MonadIO)
21 22
22 23 import Network.OAuth2.HTTP.HttpClient
23 24 import Network.OAuth2.OAuth2
24 25
25 26 import Utils
26 27
  28 +---------------------------------------------------------------
  29 +
  30 +
27 31 accountUidUri :: BS.ByteString
28 32 accountUidUri = pack' "https://api.weibo.com/2/account/get_uid.json"
29 33
@@ -33,7 +37,6 @@ accountShowUri = pack' "https://api.weibo.com/2/users/show.json"
33 37 ---------------------------------------------------------------
34 38
35 39
36   -
37 40 -- | UID
38 41 data WeiboUserId = WeiboUserId { weiboUserId :: Int } deriving (Show)
39 42
@@ -73,10 +76,11 @@ apiUrlGet2 uri (token, uid) = uri `BS.append` (renderSimpleQuery True $
73 76
74 77 handleResponse :: Response BSL.ByteString -> IO BSL.ByteString
75 78 handleResponse rsp = if (HT.statusCode . responseStatus) rsp == 200
76   - then return $ responseBody rsp
77   - else throwIO . OAuthException $ "Gaining uid failed: " ++ BSL.unpack (responseBody rsp)
  79 + then do
  80 + --print $ responseHeaders rsp
  81 + return $ responseBody rsp
  82 + else throwIO . OAuthException $ "Gaining uid failed: " ++ BSL.unpack (responseBody rsp)
78 83
79 84 uidToParam :: WeiboUserId -> [(BS.ByteString, BS.ByteString)]
80 85 uidToParam (WeiboUserId uid) = [("uid", intToByteString uid)]
81 86
82   -
19 test/snap.hs
@@ -12,9 +12,10 @@ module Main where
12 12
13 13 ------------------------------------------------------------------------------
14 14 import Control.Category
  15 +import Control.Monad
15 16 import Control.Exception (SomeException, try)
16 17 import Data.ByteString (ByteString)
17   -import Data.Maybe (fromMaybe, fromJust)
  18 +import Data.Maybe
18 19 import Network.HTTP.Conduit (responseBody)
19 20 import Network.HTTP.Types (renderSimpleQuery)
20 21 import Prelude hiding ((.))
@@ -39,8 +40,8 @@ import Snap.Loader.Prod
39 40 import Network.OAuth2.OAuth2
40 41 import Network.OAuth2.HTTP.HttpClient
41 42
42   -import Key
43   -import Api
  43 +import Weibo.Key
  44 +import Weibo.Api
44 45 import Utils
45 46
46 47 ------------------------------------------------------------------------------
@@ -73,12 +74,6 @@ weiboOAuth = weiboKey { oauthOAuthorizeEndpoint = "https://api.weibo.com/oauth2/
73 74 , oauthAccessToken = Nothing
74 75 }
75 76
76   -googleOAuth :: OAuth2
77   -googleOAuth = googleKeys { oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth"
78   - , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token"
79   - , oauthAccessToken = Nothing
80   - }
81   -
82 77 decodedParam :: MonadSnap m => ByteString -> m ByteString
83 78 decodedParam p = fromMaybe "" <$> getParam p
84 79
@@ -91,11 +86,17 @@ weiboCallback = oauthCallbackHandler $ Just "/accountShow"
91 86 accountShow :: Handler App App ()
92 87 accountShow = do
93 88 oauth <- readOAuthMVar
  89 + redirectToLogin oauth
94 90 maybeUID <- liftIO $ requestUid oauth
95 91 case maybeUID of
96 92 Just uid -> (writeText . lbsToText) =<< liftIO (requestAccount oauth uid)
97 93 _ -> writeBS "Failed at getting UID."
98 94
  95 +-- | Redirect to login page if not login yet.
  96 +--
  97 +redirectToLogin :: OAuth2 -> Handler App App ()
  98 +redirectToLogin oa = when (isNothing $ oauthAccessToken oa) $ redirect "weibo"
  99 +
99 100 test :: Handler App App ()
100 101 test = do
101 102 ss <- readOAuthMVar
30 test/unit-test.hs
@@ -2,7 +2,16 @@
2 2
3 3 import Control.Category
4 4 import Prelude hiding ((.))
5   -import Snap
  5 +import Snap hiding (Response)
  6 +import Network.HTTP.Conduit
  7 +import Control.Monad.Trans (liftIO)
  8 +import Control.Monad.IO.Class (MonadIO)
  9 +import qualified Data.ByteString.Lazy.Char8 as BSL
  10 +import Data.Aeson (decode)
  11 +import Test.HUnit
  12 +
  13 +import Network.OAuth2.OAuth2
  14 +import Utils
6 15
7 16 data Quux = Quux
8 17
@@ -12,3 +21,22 @@ makeLenses [''Foo]
12 21
13 22 --appQuuxLens :: Lens Foo Quux
14 23 --appQuuxLens = quux . snapletValue . Foo
  24 +
  25 +
  26 +main :: IO ()
  27 +main = do
  28 + print prop_getUid
  29 + print prop_getInvalidUid
  30 + print $ intToByteString 1234
  31 +
  32 +invalidUidString :: BSL.ByteString
  33 +invalidUidString = "{\"uid\" : \"222222\" }"
  34 +
  35 +prop_getInvalidUid :: Maybe WeiboUserId
  36 +prop_getInvalidUid = decode invalidUidString
  37 +
  38 +uidString :: BSL.ByteString
  39 +uidString = "{\"uid\" : 222222 }"
  40 +
  41 +prop_getUid :: Maybe WeiboUserId
  42 +prop_getUid = decode uidString

No commit comments for this range

Something went wrong with that request. Please try again.