{-# LANGUAGE TupleSections #-}
import Network.HTTP
import Network.URI
import Data.List
import System.Random
import System.Time
import Control.Arrow
import Control.Applicative
import Data.Digest.Pure.SHA
import qualified Codec.Binary.Base64 as B64
import qualified Data.ByteString.Lazy as L
-- OAuth型
data OAuth = OAuth {
}
-- パラメータ型
-- パラメータをパース
parseParameter
:: String -> [Parameter
]parseParameter
= map splitByEqual
. splitByAnd
where
splitByAnd str
= case span (/= '&') str
of (x, "") -> [x]
(x, _:xs) -> x : splitByAnd xs
splitByEqual
= second
tail . span (/= '=')
-- パラメータのリストから特定のパラメータを取得
getParameter
:: Monad m
=> [Parameter
] -> String -> m Parameter
getParameter parameters parameterName =
case find
((== parameterName
) . fst) parameters
of Just parameter
-> return parameter
Nothing
-> fail "Parameter not found."
-- パラメータを '=' で結合し、 ',' 区切りで並べる
urlEncodeParams
:: [Parameter
] -> StringurlEncodeParams parameters
= intercalate
", " . map (\
(x
, y
) -> urlEncode x
++ "=" ++ doubleQuote
(urlEncode y
)) $ parameters
where
doubleQuote str = "\"" ++ str ++ "\""
-- リクエストの署名を生成
genSignature consumerSecret tokenSecret method uri parameters =
let parameters' = urlEncode . urlEncodeVars . sort $ parameters -- パラメータのソート・結合・エンコード
signatureKey = L.pack . map (fromIntegral . ord) $ urlEncode consumerSecret ++ "&" ++ urlEncode tokenSecret -- 署名キー生成
signatureBaseString = L.pack . map (fromIntegral . ord) $ urlEncode (show method) ++ "&" ++ urlEncode uri ++ "&" ++ parameters' -- 署名対象文字列生成
in
B64.encode . L.unpack . bytestringDigest $ hmacSha1 signatureKey signatureBaseString -- HMAC-SHA1アルゴリズムでダイジェスト値を生成・Base64でエンコード
-- リクエストトークン取得URL
requestTokenURL = "http://a...content-available-to-author-only...r.com/oauth/request_token"
authorizeURL = "http://a...content-available-to-author-only...r.com/oauth/authorize"
-- アクセストークン取得URL
accessTokenURL = "http://a...content-available-to-author-only...r.com/oauth/access_token"
-- OAuth Request 生成
oauthRequest
:: OAuth
-> String -> String -> [Parameter
] -> IO Request
_String
oauthRequest oauth url token parameter = do
let key = consumerKey oauth -- Consumer key
secret = consumerSecret oauth -- Consumer Secret
uri = fromJust . parseURI $ url -- URI
timestamp
<- show . (\
(TOD i
_) -> i
) <$> getClockTime
-- タイムスタンプ取得 let authorizationParameters_ = parameter ++ [
("oauth_consumer_key", key),
("oauth_nonce", nonce),
("oauth_timestamp", timestamp),
("oauth_signature_method", "HMAC-SHA1"),
("oauth_version", "1.0")
] -- 各種基本パラメータをセット
signature = genSignature secret token POST url authorizationParameters_ -- 署名生成
authorizationParameters = authorizationParameters_++[("oauth_signature", signature)] -- 署名をパラメータに加える
authorizationHeader = mkHeader HdrAuthorization . ("OAuth "++) . urlEncodeParams $ authorizationParameters -- Authorizationヘッダ生成
-- Request を構成
rqURI = uri,
rqMethod = POST,
rqHeaders = [authorizationHeader],
rqBody = ""
}
-- simpleHTTP のIO版
simpleHTTPIO
:: HStream a
=> Request a
-> IO (Response a
)simpleHTTPIO req = do
res <- simpleHTTP req
case res of
Right res' -> return res'
main = do
-- Consumer Key / Consumer Secret読み込み
fin <- openFile "./config.ini" ReadMode
(consumerKey:consumerSecret:
_) <- fmap lines $ hGetContents fin
let oauth = OAuth consumerKey consumerSecret "" ""
-- リクエストトークン発行要求リクエスト生成
requestForGetRequestToken <- oauthRequest oauth requestTokenURL "" []
-- リクエストトークン取得
requestTokenParameters
<- (fmap $ parseParameter
. rspBody
) . simpleHTTPIO
$ requestForGetRequestToken
requestToken <- getParameter requestTokenParameters "oauth_token"
requestTokenSecret <- getParameter requestTokenParameters "oauth_token_secret"
-- 認証ページのアドレス表示
putStrLn $ authorizeURL
++ "?" ++ urlEncodeVars
[requestToken
] -- PIN入力 -> oauth_verifierパラメータとして束縛
verifier
<- ("oauth_varifier",) <$> getLine -- アクセストークン発行要求リクエスト生成
requestForGetAccessToken
<- oauthRequest oauth accessTokenURL
(snd requestTokenSecret
) [requestToken
, verifier
] -- アクセストークン取得
accessTokenParameters
<- (fmap $ parseParameter
. rspBody
) . simpleHTTPIO
$ requestForGetAccessToken
accessToken <- getParameter accessTokenParameters "oauth_token"
accessTokenSecret <- getParameter accessTokenParameters "oauth_token_secret"
ey0jIExBTkdVQUdFIFR1cGxlU2VjdGlvbnMgIy19CmltcG9ydCBOZXR3b3JrLkhUVFAKaW1wb3J0IE5ldHdvcmsuVVJJCmltcG9ydCBEYXRhLk1heWJlCmltcG9ydCBEYXRhLkxpc3QKaW1wb3J0IFN5c3RlbS5JTwppbXBvcnQgU3lzdGVtLlJhbmRvbQppbXBvcnQgU3lzdGVtLlRpbWUKaW1wb3J0IENvbnRyb2wuQXJyb3cKaW1wb3J0IENvbnRyb2wuQXBwbGljYXRpdmUKaW1wb3J0IERhdGEuRGlnZXN0LlB1cmUuU0hBCmltcG9ydCBEYXRhLkNoYXIKaW1wb3J0IHF1YWxpZmllZCBDb2RlYy5CaW5hcnkuQmFzZTY0IGFzIEI2NAppbXBvcnQgcXVhbGlmaWVkIERhdGEuQnl0ZVN0cmluZy5MYXp5IGFzIEwKCi0tIE9BdXRo5Z6LCmRhdGEgT0F1dGggPSBPQXV0aCB7CiAgICAgIGNvbnN1bWVyS2V5IDo6IFN0cmluZywKICAgICAgY29uc3VtZXJTZWNyZXQgOjogU3RyaW5nLAogICAgICBhY2Nlc3NUb2tlbiA6OiBTdHJpbmcsCiAgICAgIGFjY2Vzc1Rva2VuU2VjcmV0IDo6IFN0cmluZwogICAgfQotLSDjg5Hjg6njg6Hjg7zjgr/lnosKdHlwZSBQYXJhbWV0ZXIgPSAoU3RyaW5nLCBTdHJpbmcpCgotLSDjg5Hjg6njg6Hjg7zjgr/jgpLjg5Hjg7zjgrkKcGFyc2VQYXJhbWV0ZXIgOjogU3RyaW5nIC0+IFtQYXJhbWV0ZXJdCnBhcnNlUGFyYW1ldGVyID0gbWFwIHNwbGl0QnlFcXVhbCAuIHNwbGl0QnlBbmQKICAgIHdoZXJlCiAgICAgIHNwbGl0QnlBbmQgc3RyID0gY2FzZSBzcGFuICgvPSAnJicpIHN0ciBvZgogICAgICAgICAgICAgICAgICAgICAgICAgKHgsICIiKSAtPiBbeF0KICAgICAgICAgICAgICAgICAgICAgICAgICh4LCBfOnhzKSAtPiB4IDogc3BsaXRCeUFuZCB4cwogICAgICBzcGxpdEJ5RXF1YWwgPSBzZWNvbmQgdGFpbCAuIHNwYW4gKC89ICc9JykKCi0tIOODkeODqeODoeODvOOCv+OBruODquOCueODiOOBi+OCieeJueWumuOBruODkeODqeODoeODvOOCv+OCkuWPluW+lwpnZXRQYXJhbWV0ZXIgOjogTW9uYWQgbSA9PiBbUGFyYW1ldGVyXSAtPiBTdHJpbmcgLT4gbSBQYXJhbWV0ZXIKZ2V0UGFyYW1ldGVyIHBhcmFtZXRlcnMgcGFyYW1ldGVyTmFtZSA9CiAgICBjYXNlIGZpbmQgKCg9PSBwYXJhbWV0ZXJOYW1lKSAuIGZzdCkgcGFyYW1ldGVycyBvZgogICAgICBKdXN0IHBhcmFtZXRlciAtPiByZXR1cm4gcGFyYW1ldGVyCiAgICAgIE5vdGhpbmcgLT4gZmFpbCAiUGFyYW1ldGVyIG5vdCBmb3VuZC4iCgotLSDjg5Hjg6njg6Hjg7zjgr/jgpIgJz0nIOOBp+e1kOWQiOOBl+OAgSAnLCcg5Yy65YiH44KK44Gn5Lim44G544KLCnVybEVuY29kZVBhcmFtcyA6OiBbUGFyYW1ldGVyXSAtPiBTdHJpbmcKdXJsRW5jb2RlUGFyYW1zIHBhcmFtZXRlcnMgPSBpbnRlcmNhbGF0ZSAiLCAiIC4gbWFwIChcKHgsIHkpIC0+IHVybEVuY29kZSB4ICsrICI9IiArKyBkb3VibGVRdW90ZSAodXJsRW5jb2RlIHkpKSAkIHBhcmFtZXRlcnMKICAgIHdoZXJlCiAgICAgIGRvdWJsZVF1b3RlIHN0ciA9ICJcIiIgKysgc3RyICsrICJcIiIKCi0tIOODquOCr+OCqOOCueODiOOBrue9suWQjeOCkueUn+aIkApnZW5TaWduYXR1cmUgOjogU3RyaW5nIC0+IFN0cmluZyAtPiBSZXF1ZXN0TWV0aG9kIC0+IFN0cmluZyAtPiBbUGFyYW1ldGVyXSAtPiBTdHJpbmcKZ2VuU2lnbmF0dXJlIGNvbnN1bWVyU2VjcmV0IHRva2VuU2VjcmV0IG1ldGhvZCB1cmkgcGFyYW1ldGVycyA9CiAgICBsZXQgcGFyYW1ldGVycycgPSB1cmxFbmNvZGUgLiB1cmxFbmNvZGVWYXJzIC4gc29ydCAkIHBhcmFtZXRlcnMgLS0g44OR44Op44Oh44O844K/44Gu44K944O844OI44O757WQ5ZCI44O744Ko44Oz44Kz44O844OJCiAgICAgICAgc2lnbmF0dXJlS2V5ID0gTC5wYWNrIC4gbWFwIChmcm9tSW50ZWdyYWwgLiBvcmQpICQgdXJsRW5jb2RlIGNvbnN1bWVyU2VjcmV0ICsrICImIiArKyB1cmxFbmNvZGUgdG9rZW5TZWNyZXQgLS0g572y5ZCN44Kt44O855Sf5oiQCiAgICAgICAgc2lnbmF0dXJlQmFzZVN0cmluZyA9IEwucGFjayAuIG1hcCAoZnJvbUludGVncmFsIC4gb3JkKSAkIHVybEVuY29kZSAoc2hvdyBtZXRob2QpICsrICImIiArKyB1cmxFbmNvZGUgdXJpICsrICImIiArKyBwYXJhbWV0ZXJzJyAtLSDnvbLlkI3lr77osaHmloflrZfliJfnlJ/miJAKICAgIGluCiAgICAgICAgQjY0LmVuY29kZSAuIEwudW5wYWNrIC4gYnl0ZXN0cmluZ0RpZ2VzdCAkIGhtYWNTaGExIHNpZ25hdHVyZUtleSBzaWduYXR1cmVCYXNlU3RyaW5nIC0tIEhNQUMtU0hBMeOCouODq+OCtOODquOCuuODoOOBp+ODgOOCpOOCuOOCp+OCueODiOWApOOCkueUn+aIkOODu0Jhc2U2NOOBp+OCqOODs+OCs+ODvOODiQoKLS0g44Oq44Kv44Ko44K544OI44OI44O844Kv44Oz5Y+W5b6XVVJMCnJlcXVlc3RUb2tlblVSTCA9ICJodHRwOi8vYS4uLmNvbnRlbnQtYXZhaWxhYmxlLXRvLWF1dGhvci1vbmx5Li4uci5jb20vb2F1dGgvcmVxdWVzdF90b2tlbiIKYXV0aG9yaXplVVJMID0gImh0dHA6Ly9hLi4uY29udGVudC1hdmFpbGFibGUtdG8tYXV0aG9yLW9ubHkuLi5yLmNvbS9vYXV0aC9hdXRob3JpemUiCi0tIOOCouOCr+OCu+OCueODiOODvOOCr+ODs+WPluW+l1VSTAphY2Nlc3NUb2tlblVSTCA9ICJodHRwOi8vYS4uLmNvbnRlbnQtYXZhaWxhYmxlLXRvLWF1dGhvci1vbmx5Li4uci5jb20vb2F1dGgvYWNjZXNzX3Rva2VuIgoKLS0gT0F1dGggUmVxdWVzdCDnlJ/miJAKb2F1dGhSZXF1ZXN0IDo6IE9BdXRoIC0+IFN0cmluZyAtPiBTdHJpbmcgLT4gW1BhcmFtZXRlcl0gLT4gSU8gUmVxdWVzdF9TdHJpbmcKb2F1dGhSZXF1ZXN0IG9hdXRoIHVybCB0b2tlbiBwYXJhbWV0ZXIgPSBkbwogICAgbGV0IGtleSA9IGNvbnN1bWVyS2V5IG9hdXRoIC0tIENvbnN1bWVyIGtleQogICAgICAgIHNlY3JldCA9IGNvbnN1bWVyU2VjcmV0IG9hdXRoIC0tIENvbnN1bWVyIFNlY3JldAogICAgICAgIHVyaSA9IGZyb21KdXN0IC4gcGFyc2VVUkkgJCB1cmwgLS0gVVJJCiAgICB0aW1lc3RhbXAgPC0gc2hvdyAuIChcKFRPRCBpIF8pIC0+IGkpIDwkPiBnZXRDbG9ja1RpbWUgLS0g44K/44Kk44Og44K544K/44Oz44OX5Y+W5b6XCiAgICBub25jZSA8LSBzaG93IDwkPiByYW5kb21SSU8gKDAsIG1heEJvdW5kOjpJbnQpIC0tIOS5seaVsOWPluW+lwogICAgbGV0IGF1dGhvcml6YXRpb25QYXJhbWV0ZXJzXyA9IHBhcmFtZXRlciArKyBbCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgKCJvYXV0aF9jb25zdW1lcl9rZXkiLCBrZXkpLAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICgib2F1dGhfbm9uY2UiLCBub25jZSksCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgKCJvYXV0aF90aW1lc3RhbXAiLCB0aW1lc3RhbXApLAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICgib2F1dGhfc2lnbmF0dXJlX21ldGhvZCIsICJITUFDLVNIQTEiKSwKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAoIm9hdXRoX3ZlcnNpb24iLCAiMS4wIikKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIF0gLS0g5ZCE56iu5Z+65pys44OR44Op44Oh44O844K/44KS44K744OD44OICiAgICAgICAgc2lnbmF0dXJlID0gZ2VuU2lnbmF0dXJlIHNlY3JldCB0b2tlbiBQT1NUIHVybCBhdXRob3JpemF0aW9uUGFyYW1ldGVyc18gLS0g572y5ZCN55Sf5oiQCiAgICAgICAgYXV0aG9yaXphdGlvblBhcmFtZXRlcnMgPSBhdXRob3JpemF0aW9uUGFyYW1ldGVyc18rK1soIm9hdXRoX3NpZ25hdHVyZSIsIHNpZ25hdHVyZSldIC0tIOe9suWQjeOCkuODkeODqeODoeODvOOCv+OBq+WKoOOBiOOCiwogICAgICAgIGF1dGhvcml6YXRpb25IZWFkZXIgPSBta0hlYWRlciBIZHJBdXRob3JpemF0aW9uIC4gKCJPQXV0aCAiKyspIC4gdXJsRW5jb2RlUGFyYW1zICQgYXV0aG9yaXphdGlvblBhcmFtZXRlcnMgLS0gQXV0aG9yaXphdGlvbuODmOODg+ODgOeUn+aIkAogICAgLS0gUmVxdWVzdCDjgpLmp4vmiJAKICAgIHJldHVybiAkIFJlcXVlc3QgewogICAgICAgICAgICAgICAgIHJxVVJJID0gdXJpLAogICAgICAgICAgICAgICAgIHJxTWV0aG9kID0gUE9TVCwKICAgICAgICAgICAgICAgICBycUhlYWRlcnMgPSBbYXV0aG9yaXphdGlvbkhlYWRlcl0sCiAgICAgICAgICAgICAgICAgcnFCb2R5ID0gIiIKICAgICAgICAgICAgICAgfQoKLS0gc2ltcGxlSFRUUCDjga5JT+eJiApzaW1wbGVIVFRQSU8gOjogSFN0cmVhbSBhID0+IFJlcXVlc3QgYSAtPiBJTyAoUmVzcG9uc2UgYSkKc2ltcGxlSFRUUElPIHJlcSA9IGRvCiAgcmVzIDwtIHNpbXBsZUhUVFAgcmVxCiAgY2FzZSByZXMgb2YKICAgIFJpZ2h0IHJlcycgLT4gcmV0dXJuIHJlcycKICAgIExlZnQgZXJyIC0+IGZhaWwuc2hvdyAkIGVycgoKbWFpbiA6OiBJTyAoKQptYWluID0gZG8KICAtLSBDb25zdW1lciBLZXkgLyBDb25zdW1lciBTZWNyZXToqq3jgb/ovrzjgb8KICBmaW4gPC0gb3BlbkZpbGUgIi4vY29uZmlnLmluaSIgUmVhZE1vZGUKICAoY29uc3VtZXJLZXk6Y29uc3VtZXJTZWNyZXQ6XykgPC0gZm1hcCBsaW5lcyAkIGhHZXRDb250ZW50cyBmaW4KICBsZXQgb2F1dGggPSBPQXV0aCBjb25zdW1lcktleSBjb25zdW1lclNlY3JldCAiIiAiIgogIC0tIOODquOCr+OCqOOCueODiOODiOODvOOCr+ODs+eZuuihjOimgeaxguODquOCr+OCqOOCueODiOeUn+aIkAogIHJlcXVlc3RGb3JHZXRSZXF1ZXN0VG9rZW4gPC0gb2F1dGhSZXF1ZXN0IG9hdXRoIHJlcXVlc3RUb2tlblVSTCAiIiBbXQogIC0tIOODquOCr+OCqOOCueODiOODiOODvOOCr+ODs+WPluW+lwogIHJlcXVlc3RUb2tlblBhcmFtZXRlcnMgPC0gKGZtYXAgJCBwYXJzZVBhcmFtZXRlciAuIHJzcEJvZHkpIC4gc2ltcGxlSFRUUElPICQgcmVxdWVzdEZvckdldFJlcXVlc3RUb2tlbgogIHJlcXVlc3RUb2tlbiA8LSBnZXRQYXJhbWV0ZXIgcmVxdWVzdFRva2VuUGFyYW1ldGVycyAib2F1dGhfdG9rZW4iCiAgcmVxdWVzdFRva2VuU2VjcmV0IDwtIGdldFBhcmFtZXRlciByZXF1ZXN0VG9rZW5QYXJhbWV0ZXJzICJvYXV0aF90b2tlbl9zZWNyZXQiCiAgLS0g6KqN6Ki844Oa44O844K444Gu44Ki44OJ44Os44K56KGo56S6CiAgcHV0U3RyTG4gJCBhdXRob3JpemVVUkwgKysgIj8iICsrIHVybEVuY29kZVZhcnMgW3JlcXVlc3RUb2tlbl0KICAtLSBQSU7lhaXlipsgLT4gb2F1dGhfdmVyaWZpZXLjg5Hjg6njg6Hjg7zjgr/jgajjgZfjgabmnZ/nuJsKICB2ZXJpZmllciA8LSAoIm9hdXRoX3ZhcmlmaWVyIiwpIDwkPiBnZXRMaW5lCiAgLS0g44Ki44Kv44K744K544OI44O844Kv44Oz55m66KGM6KaB5rGC44Oq44Kv44Ko44K544OI55Sf5oiQCiAgcmVxdWVzdEZvckdldEFjY2Vzc1Rva2VuIDwtIG9hdXRoUmVxdWVzdCBvYXV0aCBhY2Nlc3NUb2tlblVSTCAoc25kIHJlcXVlc3RUb2tlblNlY3JldCkgW3JlcXVlc3RUb2tlbiwgdmVyaWZpZXJdCiAgLS0g44Ki44Kv44K744K544OI44O844Kv44Oz5Y+W5b6XCiAgYWNjZXNzVG9rZW5QYXJhbWV0ZXJzIDwtIChmbWFwICQgcGFyc2VQYXJhbWV0ZXIgLiByc3BCb2R5KSAuIHNpbXBsZUhUVFBJTyAkIHJlcXVlc3RGb3JHZXRBY2Nlc3NUb2tlbgogIGFjY2Vzc1Rva2VuIDwtIGdldFBhcmFtZXRlciBhY2Nlc3NUb2tlblBhcmFtZXRlcnMgIm9hdXRoX3Rva2VuIgogIGFjY2Vzc1Rva2VuU2VjcmV0IDwtIGdldFBhcmFtZXRlciBhY2Nlc3NUb2tlblBhcmFtZXRlcnMgIm9hdXRoX3Rva2VuX3NlY3JldCIKICBwdXRTdHJMbiAkICJhY2Nlc3NUb2tlbjogIiArKyBzbmQgYWNjZXNzVG9rZW4=