Haskell で OAuth

hoauth があるけどこれまた使いにくい,というか自分には使い方がわからなかったので自分で書いた.
HTTP の Request_String を作るのでこんなかんじに使える.

import Control.Applicative ((<$>))
import Network.URI
import Network.HTTP
import qualified Text.JSON as J
import Data.IntSet (IntSet)
import qualified Data.IntSet as S
import OAuth

getFollowerIds :: OAuth -> IO (Either String IntSet)
getFollowerIds oauth =
  J.resultToEither . J.decode
  <$> (genOAuthRequest oauth HMACSHA1 GET uri [] >>= simpleHTTP >>= getResponseBody)
  where
    Just uri = parseURI "http://api.twitter.com/1/followers/ids.json"

postStatus :: OAuth -> String -> IO (Either String J.JSValue)
postStatus oauth text =
  J.resultToEither . J.decode
  <$> (genOAuthRequest oauth HMACSHA1 POST uri [("status", text)] >>= simpleHTTP >>= getResponseBody)
  where
    Just uri = parseURI "http://api.twitter.com/1/statuses/update.json"


base64 のために dataencSHA1 のために SHA に依存しているので cabal 等で予めインストールしておく必要がある.
それ以外のパッケージは Haskell Platform に含まれているので改めてインストールする必要は無いはず.
OAuth の仕様から,HMAC-SHA1 のときの signature を生成する際に各パラメータをキーでソートしておく必要があるのを見落としていてしばらくハマったりしてた.

module OAuth (
    genOAuthRequest
  , OAuth (..)
  , SignatureMethod (..)
  ) where

import Data.List (sort, intercalate)
import Control.Applicative ((<$>))
import System.Time (ClockTime(..), getClockTime)
import System.Random (randomRIO)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import Network.URI
import Network.HTTP
import Data.Digest.Pure.SHA (hmacSha1, bytestringDigest)
import qualified Codec.Binary.Base64 as B64

data OAuth = OAuth {
    consumerKey :: String
  , consumerSecret :: String
  , accessToken :: String
  , accessTokenSecret :: String
  } deriving (Show, Eq)

data SignatureMethod = PLAINTEXT | HMACSHA1 deriving (Show)

getUnixTime :: IO Integer
getUnixTime = (\(TOD i _) -> i) <$> getClockTime

encodeURIComponent :: String -> String
encodeURIComponent = escapeURIString isUnreserved

mkOAuthHeader :: [(String,String)] -> String
mkOAuthHeader = ("OAuth " ++) . intercalate ", " . map (\(k,v) -> encodeURIComponent k ++ "=\"" ++ encodeURIComponent v ++ "\"")

genOAuthRequest :: OAuth -> SignatureMethod -> RequestMethod -> URI -> [(String,String)] -> IO Request_String
genOAuthRequest oauth sigMeth reqMeth uri params = do
  timestamp <- show <$> getUnixTime
  nonce <- show <$> randomRIO (0,maxBound::Int)
  let oauthParams = [ ("oauth_consumer_key", consumerKey oauth)
                    , ("oauth_token", accessToken oauth)
                    , ("oauth_signature_method", "HMAC-SHA1")
                    , ("oauth_timestamp", timestamp)
                    , ("oauth_nonce", nonce)
                    , ("oauth_version", "1.0")
                    ]
      key = consumerSecret oauth ++ "&" ++ accessTokenSecret oauth
      base = L8.pack . intercalate "&" . map encodeURIComponent
              $ [show reqMeth, show uri, urlEncodeVars (sort $ oauthParams ++ params)]
      sig = case sigMeth of
              PLAINTEXT -> key
              HMACSHA1 -> B64.encode . L.unpack . bytestringDigest $ hmacSha1 (L8.pack key) base
      hdr = mkOAuthHeader $ ("oauth_signature",sig):oauthParams
      q = urlEncodeVars params
      req = case reqMeth of
              GET -> Request { rqMethod = GET, rqHeaders = [] , rqBody = ""
                             , rqURI = uri { uriQuery = '?' : q }
                             }
              POST -> Request { rqMethod = POST, rqBody = q, rqURI = uri
                              , rqHeaders = [ mkHeader HdrContentType "application/x-www-form-urlencoded"
                                            , mkHeader HdrContentLength (show $ length q) ]
                              }
              _ -> Request { rqMethod = reqMeth, rqHeaders = [], rqBody = "" , rqURI = uri }

  return $ insertHeader HdrAuthorization hdr req