fork download
copy 
  1. {-# LANGUAGE TupleSections #-}
  2. import Network.HTTP
  3. import Network.URI
  4. import Data.Maybe
  5. import Data.List
  6. import System.IO
  7. import System.Random
  8. import System.Time
  9. import Control.Arrow
  10. import Control.Applicative
  11. import Data.Digest.Pure.SHA
  12. import Codec.Binary.UTF8.String (encodeString)
  13. import Data.Char
  14. import qualified Codec.Binary.Base64 as B64
  15. import qualified Data.ByteString.Lazy as L
  16.  
  17. -- OAuth型
  18. data OAuth = OAuth {
  19.       consumerKey :: String,
  20.       consumerSecret :: String,
  21.       accessToken :: String,
  22.       accessTokenSecret :: String
  23.     }
  24. -- パラメータ型
  25. type Parameter = (String, String)
  26.  
  27. -- パラメータをパース
  28. parseParameter :: String -> [Parameter]
  29. parseParameter = map splitByEqual . splitByAnd
  30.     where
  31.       splitByAnd str = case span (/= '&') str of
  32.                          (x, "") -> [x]
  33.                          (x, _:xs) -> x : splitByAnd xs
  34.       splitByEqual = second tail . span (/= '=')
  35.  
  36. -- パラメータのリストから特定のパラメータを取得
  37. getParameter :: Monad m => [Parameter] -> String -> m Parameter
  38. getParameter parameters parameterName =
  39.     case find ((== parameterName) . fst) parameters of
  40.       Just parameter -> return parameter
  41.       Nothing -> fail "Parameter not found."
  42.  
  43. -- パラメータを '=' で結合し、 ',' 区切りで並べる
  44. urlEncodeParams :: [Parameter] -> String
  45. urlEncodeParams parameters = intercalate ", " . map (\(x, y) -> urlEncode x ++ "=" ++ doubleQuote (urlEncode y)) $ parameters
  46.     where
  47.       doubleQuote str = "\"" ++ str ++ "\""
  48.  
  49. -- リクエストの署名を生成
  50. genSignature :: String -> String -> RequestMethod -> String -> [Parameter] -> String
  51. genSignature consumerSecret tokenSecret method uri parameters =
  52.     let parameters' = urlEncode . urlEncodeVars . sort $ parameters -- パラメータのソート・結合・エンコード
  53.         signatureKey = L.pack . map (fromIntegral . ord) $ urlEncode consumerSecret ++ "&" ++ urlEncode tokenSecret -- 署名キー生成
  54.         signatureBaseString = L.pack . map (fromIntegral . ord) $ urlEncode (show method) ++ "&" ++ urlEncode uri ++ "&" ++ parameters' -- 署名対象文字列生成
  55.     in
  56.         B64.encode . L.unpack . bytestringDigest $ hmacSha1 signatureKey signatureBaseString -- HMAC-SHA1アルゴリズムでダイジェスト値を生成・Base64でエンコード
  57.  
  58. -- リクエストトークン取得URL
  59. requestTokenURL = "http://a...content-available-to-author-only...r.com/oauth/request_token"
  60. authorizeURL = "http://a...content-available-to-author-only...r.com/oauth/authorize"
  61. -- アクセストークン取得URL
  62. accessTokenURL = "http://a...content-available-to-author-only...r.com/oauth/access_token"
  63.  
  64. -- APIリクエストURL
  65. apiRequestURL :: String -> String
  66. apiRequestURL api = "http://a...content-available-to-author-only...r.com/1/statuses/" ++ api ++ ".json"
  67.  
  68. -- OAuth Request 生成
  69. oauthRequest :: OAuth -> String -> String -> [Parameter] -> IO Request_String
  70. oauthRequest oauth url token parameter = do
  71.     let key = consumerKey oauth -- Consumer key
  72.         secret = consumerSecret oauth -- Consumer Secret
  73.         uri = fromJust . parseURI $ url -- URI
  74.     timestamp <- show . (\(TOD i _) -> i) <$> getClockTime -- タイムスタンプ取得
  75.     nonce <- show <$> randomRIO (0, maxBound::Int) -- 乱数取得
  76.     let authorizationParameters_ = parameter ++ [
  77.                                 ("oauth_consumer_key", key),
  78.                                 ("oauth_nonce", nonce),
  79.                                 ("oauth_timestamp", timestamp),
  80.                                 ("oauth_signature_method", "HMAC-SHA1"),
  81.                                 ("oauth_version", "1.0")
  82.                                ] -- 各種基本パラメータをセット
  83.         signature = genSignature secret token POST url authorizationParameters_ -- 署名生成
  84.         authorizationParameters = authorizationParameters_++[("oauth_signature", signature)] -- 署名をパラメータに加える
  85.         authorizationHeader = mkHeader HdrAuthorization . ("OAuth "++) . urlEncodeParams $ authorizationParameters -- Authorizationヘッダ生成
  86.     -- Request を構成
  87.     return $ Request {
  88.                  rqURI = uri,
  89.                  rqMethod = POST,
  90.                  rqHeaders = [authorizationHeader],
  91.                  rqBody = ""
  92.                }
  93.  
  94. -- APIリクエスト
  95. apiRequest :: OAuth -> String -> RequestMethod -> [Parameter] -> IO Request_String
  96. apiRequest oauth api method args = do
  97.     let key = consumerKey oauth -- Consumer key
  98.         token = accessToken oauth -- AccessToken
  99.         secret_Consumer = consumerSecret oauth -- Consumer Secret
  100.         secret_AccessToken = accessTokenSecret oauth -- AccessToken Secret
  101.         url = apiRequestURL api
  102.         uri = fromJust . parseURI $ if method == POST then url else url ++ "?" ++ urlEncodeVars args  -- URI
  103.     timestamp <- show . (\(TOD i _) -> i) <$> getClockTime -- タイムスタンプ取得
  104.     nonce <- show <$> randomRIO (0, maxBound::Int) -- 乱数取得
  105.     let authorizationParameters_ = [
  106.                                     ("oauth_token", token),
  107.                                     ("oauth_consumer_key", key),
  108.                                     ("oauth_nonce", nonce),
  109.                                     ("oauth_timestamp", timestamp),
  110.                                     ("oauth_signature_method", "HMAC-SHA1"),
  111.                                     ("oauth_version", "1.0")
  112.                                    ] -- 各種基本パラメータをセット
  113.         signature = genSignature secret_Consumer secret_AccessToken method url (args ++ authorizationParameters_) -- 署名生成
  114.         authorizationParameters = authorizationParameters_++[("oauth_signature", signature)] -- 署名をパラメータに加える
  115.         authorizationHeader = mkHeader HdrAuthorization . ("OAuth "++) . urlEncodeParams $ authorizationParameters -- Authorizationヘッダ生成
  116.         contentLengthHeader = mkHeader HdrContentLength (show . length . urlEncodeVars $ args)
  117.     -- Request を構成
  118.     return $ Request {
  119.                  rqURI = uri,
  120.                  rqMethod = method,
  121.                  rqHeaders = if method == POST then [authorizationHeader, contentLengthHeader] else [authorizationHeader] ,
  122.                  rqBody = if method == POST then urlEncodeVars args else ""
  123.                }
  124.  
  125. -- simpleHTTP のIO版
  126. simpleHTTPIO :: HStream a => Request a -> IO (Response a)
  127. simpleHTTPIO req = do
  128.   res <- simpleHTTP req
  129.   case res of
  130.     Right res' -> if rspCode res' == (2, 0, 0) then return res' else fail.show $ res'
  131.     Left err -> fail.show $ err
  132.  
  133. -- ツイートする(Ctrl+Cで抜ける)
  134. main_loop :: OAuth -> IO ()
  135. main_loop oauth = do
  136.   content <- getLine
  137.   tweet <- apiRequest oauth "update" POST [("status", encodeString content)]
  138.   res <- simpleHTTPIO tweet
  139.   main_loop oauth
  140.  
  141. main :: IO ()
  142. main = do
  143.   -- Consumer Key / Consumer Secret読み込み
  144.   fin <- openFile "./config.ini" ReadMode
  145.   (consumerKey:consumerSecret:_) <- fmap lines $ hGetContents fin
  146.   let oauth_ = OAuth consumerKey consumerSecret "" ""
  147.   -- リクエストトークン発行要求リクエスト生成
  148.   requestForGetRequestToken <- oauthRequest oauth_ requestTokenURL "" []
  149.   -- リクエストトークン取得
  150.   requestTokenParameters <- (fmap $ parseParameter . rspBody) . simpleHTTPIO $ requestForGetRequestToken
  151.   requestToken <- getParameter requestTokenParameters "oauth_token"
  152.   requestTokenSecret <- getParameter requestTokenParameters "oauth_token_secret"
  153.   -- 認証ページのアドレス表示
  154.   putStrLn $ authorizeURL ++ "?" ++ urlEncodeVars [requestToken]
  155.   -- PIN入力 -> oauth_verifierパラメータとして束縛
  156.   verifier <- ("oauth_varifier",) <$> getLine
  157.   -- アクセストークン発行要求リクエスト生成
  158.   requestForGetAccessToken <- oauthRequest oauth_ accessTokenURL (snd requestTokenSecret) [requestToken, verifier]
  159.   -- アクセストークン取得
  160.   accessTokenParameters <- (fmap $ parseParameter . rspBody) . simpleHTTPIO $ requestForGetAccessToken
  161.   accessToken <- getParameter accessTokenParameters "oauth_token"
  162.   accessTokenSecret <- getParameter accessTokenParameters "oauth_token_secret"
  163.   let oauth = OAuth consumerKey consumerSecret (snd accessToken) (snd accessTokenSecret)
  164.   main_loop oauth
  165.  
Not running #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/tJe1I
language:
Haskell (ghc 8.4.4)
created:
12 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!