e4agVxa6

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