5rSJc61u

1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3
4import Data.Aeson
5import qualified Data.ByteString.Char8 as BS
6import qualified Data.ByteString.Lazy.Char8 as BSL
7import Data.Typeable (Typeable)
8import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery)
9import qualified Network.HTTP.Types as HT
10import Network.HTTP.Conduit
11import Control.Exception (Exception, throwIO)
12import Control.Applicative ((<$>))
13import Control.Monad (mzero)
14
15import System.IO (hFlush, stdout)
16
17data OAuth2 = OAuth2
18  { oauthClientId :: BS.ByteString
19  , oauthClientSecret :: BS.ByteString
20  , oauthOAuthorizeEndpoint :: BS.ByteString
21  , oauthAccessTokenEndpoint :: BS.ByteString
22  , oauthCallback :: Maybe BS.ByteString
23    -- ^ redirect_uri
24  , oauthAccessToken :: Maybe BS.ByteString
25    -- ^ used only by signRequest
26  } deriving (Show, Eq)
27
28data OAuthException = OAuthException String
29                      deriving (Show, Eq, Typeable)
30
31instance Exception OAuthException
32
33newOAuth2 :: OAuth2
34newOAuth2 = OAuth2 { oauthClientId = error "You must specify client id."
35                   , oauthClientSecret = error "You must specify client secret."
36                   , oauthOAuthorizeEndpoint = error "You must specify authorize endpoint."
37                   , oauthAccessTokenEndpoint = error "You must specify access_token endpoint."
38                   , oauthCallback = Nothing
39                   , oauthAccessToken = Nothing
40                   }
41
42authorizationUrl :: OAuth2 -> BS.ByteString
43authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryString
44  where queryString = renderSimpleQuery True query
45        query = ("redirect_uri", oauthCallback oa) ?:
46          [ ("client_id", oauthClientId oa)
47          , ("response_type", "code")
48          ]
49
50request req = (withManager . httpLbs) (req { checkStatus = \_ _ -> Nothing })
51
52getAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString
53getAccessToken' oa code grant_type = do
54    rsp <- request req
55    if (HT.statusCode . responseStatus) rsp == 200
56        then return $ responseBody rsp
57        else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp)
58  where
59    Just req = parseUrl url
60    url = BS.unpack $ oauthAccessTokenEndpoint oa `BS.append` queryString
61    queryString = renderSimpleQuery True query
62    query =
63      ("redirect_uri", oauthCallback oa) ?:
64      ("grant_type", grant_type) ?:
65      [ ("client_id", oauthClientId oa)
66      , ("client_secret", oauthClientSecret oa)
67      , ("code", code)
68      ]
69
70postAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString
71postAccessToken' oa code grant_type = do
72    rsp <- request req
73    if (HT.statusCode . responseStatus) rsp == 200
74        then return $ responseBody rsp
75        else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp)
76  where
77    Just req = urlEncodedBody query <$> parseUrl url
78    url = BS.unpack $ oauthAccessTokenEndpoint oa
79    query =
80      ("redirect_uri", oauthCallback oa) ?:
81      ("grant_type", grant_type) ?:
82      [ ("client_id", oauthClientId oa)
83      , ("client_secret", oauthClientSecret oa)
84      , ("code", code)
85      ]
86
87
88
89(?:) :: (a, Maybe b) -> [(a, b)] -> [(a, b)]
90infixr 5 ?:
91(a, Just b)  ?: xs = (a, b):xs
92(_, Nothing) ?: xs = xs
93
94getAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken)
95getAccessToken oa code grant_type = decode <$> getAccessToken' oa code grant_type
96
97postAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken)
98postAccessToken oa code grant_type = decode <$> postAccessToken' oa code grant_type
99
100data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show)
101instance FromJSON AccessToken where
102    parseJSON (Object o) = AccessToken <$> o .: "access_token"
103    parseJSON _          = mzero
104
105signRequest :: OAuth2 -> Request m -> Request m
106signRequest oa req = req { queryString = (renderSimpleQuery False newQuery) }
107  where
108    newQuery = case oauthAccessToken oa of
109                    Just at -> ("oauth_token", at) : oldQuery
110                    _       -> ("client_id", oauthClientId oa) : ("client_secret", oauthClientSecret oa) : oldQuery
111    oldQuery = parseSimpleQuery (queryString req)
112
113main :: IO ()
114main = do let oauth = newOAuth2 { oauthClientId = "xxx"
115                                , oauthClientSecret = "xxx"
116                                , oauthCallback = Just "xxxx"
117                                , oauthOAuthorizeEndpoint = "xxx"
118                                , oauthAccessTokenEndpoint = "xxxx" }
119          print $ authorizationUrl oauth
120          putStr "visit the url and paste code here: "
121          hFlush stdout
122          code <- getLine
123          token <- postAccessToken oauth (BS.pack code) (Just "authorization_code")
124          print token