4kMHNM4B

1-- OAuth Request 生成
2oauthRequest :: OAuth -> String -> String -> [Parameter] -> IO String
3oauthRequest oauth url token parameter = do
4  timestamp <- show . (\(TOD i _) -> i) <$> getClockTime -- タイムスタンプ取得
5  nonce <- show <$> randomRIO (0, maxBound::Int) -- 乱数取得
6  let authorizationParameters_ = parameter ++ [
7                                          ("oauth_consumer_key", consumerKey oauth),
8                                          ("oauth_nonce", nonce),
9                                          ("oauth_timestamp", timestamp),
10                                          ("oauth_signature_method", "HMAC-SHA1"),
11                                          ("oauth_version", "1.0")
12                                         ] -- 各種基本パラメータをセット
13      signature = genSignature (consumerSecret oauth) token POST url authorizationParameters_ -- 署名生成
14      authorizationParameters = authorizationParameters_++[("oauth_signature", signature)] -- 署名をパラメータに加える
15      authorizationHeader = mkHeader HdrAuthorization . ("OAuth "++) . urlEncodeParams $ authorizationParameters -- Authorizationヘッダ生成
16  -- Requestを送信
17  rspBody <$> (simpleHTTPIO $ Request {
18                                  rqURI = fromJust . parseURI $ url,
19                                  rqMethod = POST,
20                                  rqHeaders = [authorizationHeader],
21                                  rqBody = ""
22                                })
23
24-- APIリクエスト
25apiRequest :: OAuth -> String -> RequestMethod -> [Parameter] -> IO String
26apiRequest oauth api method args = do
27  let url = apiRequestURL api
28      uri = fromJust . parseURI $ if method == POST then url else url ++ "?" ++ urlEncodeVars args  -- URI
29  timestamp <- show . (\(TOD i _) -> i) <$> getClockTime -- タイムスタンプ取得
30  nonce <- show <$> randomRIO (0, maxBound::Int) -- 乱数取得
31  let authorizationParameters_ = [
32       ("oauth_token", accessToken oauth),
33       ("oauth_consumer_key", consumerKey oauth),
34       ("oauth_nonce", nonce),
35       ("oauth_timestamp", timestamp),
36       ("oauth_signature_method", "HMAC-SHA1"),
37       ("oauth_version", "1.0")] -- 各種基本パラメータをセット
38      signature = genSignature (consumerSecret oauth) (accessTokenSecret oauth) method url (args ++ authorizationParameters_) -- 署名生成
39      authorizationParameters = authorizationParameters_++[("oauth_signature", signature)] -- 署名をパラメータに加える
40      authorizationHeader = mkHeader HdrAuthorization . ("OAuth "++) . urlEncodeParams $ authorizationParameters -- Authorizationヘッダ生成
41      contentLengthHeader = mkHeader HdrContentLength (show . length . urlEncodeVars $ args)
42  -- Requestを送信
43  rspBody <$> (simpleHTTPIO $ Request {
44                                  rqURI = uri,
45                                  rqMethod = method,
46                                  rqHeaders = if method == POST then [authorizationHeader, contentLengthHeader] else [authorizationHeader] ,
47                                  rqBody = if method == POST then urlEncodeVars args else ""
48                                })
49
50-- simpleHTTP のIO版
51simpleHTTPIO :: HStream a => Request a -> IO (Response a)
52simpleHTTPIO req = do
53  res <- simpleHTTP req
54  case res of
55    Right res' -> if rspCode res' == (2, 0, 0) then return res' else fail.show $ res'
56    Left err -> fail.show $ err