module Net.OAuth.OAuth10a
( auth_header
, param_string
, Param(..)
, Credentials(..)
, PercentEncode(..)
, filterNonAlphanumeric
, gen_nonce
, timestamp
, sig_base_string
, signing_key
, sign
, create_header_string
, oauth_sig
) where
import Network.HTTP.Types.Status (statusCode)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (pack, unpack)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad (forM, mapM)
import System.Entropy (getEntropy)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.List (sort, intersperse)
import Data.Monoid ((<>))
import Crypto.MAC.HMAC (hmac)
import Crypto.Hash.SHA1 (hash)
data Param = Param
{ paramKey :: ByteString
, paramValue :: ByteString
} deriving (Show, Eq, Ord)
data Credentials = Credentials
{ consumerKey :: ByteString
, consumerSecret :: ByteString
, token :: Maybe ByteString
, tokenSecret :: Maybe ByteString
} deriving (Show)
bs = BB.byteString
build = BL.toStrict . BB.toLazyByteString
filterNonAlphanumeric :: ByteString -> ByteString
filterNonAlphanumeric = BS.pack . trunc . filter f . BS.unpack where
f ch | ch >= 97 && ch <= 122 = True
| ch >= 48 && ch <= 57 = True
| otherwise = False
trunc it | length it > 32 = take 32 it
| otherwise = it
gen_nonce :: MonadIO m => m ByteString
gen_nonce = do
random_bytes <- liftIO $ getEntropy 32
return $ filterNonAlphanumeric $ B64.encode random_bytes
timestamp :: MonadIO m => m Integer
timestamp = liftIO $ round <$> getPOSIXTime
class PercentEncode t where
percent_encode :: t -> t
instance PercentEncode ByteString where
percent_encode = build . mconcat . map encodeChar . BS.unpack where
encodeChar ch | unreserved' ch = BB.word8 ch
| otherwise = h2 ch
unreserved' ch | ch >= 65 && ch <= 90 = True
| ch >= 97 && ch <= 122 = True
| ch >= 48 && ch <= 57 = True
| ch == 95 = True
| ch == 46 = True
| ch == 126 = True
| ch == 45 = True
| otherwise = False
h2 v = let (a, b) = v `divMod` 16 in bs $ BS.pack [37, h a, h b]
h i | i < 10 = 48 + i
| otherwise = 65 + i 10
instance PercentEncode Param where
percent_encode (Param a b) = Param (percent_encode a) (percent_encode b)
param_string :: [Param] -> ByteString
param_string = build .
foldl (<>) mempty . intersperse (bs "&") .
map (\(Param k v) -> (bs k) <> (bs "=") <> (bs v)) .
sort . map percent_encode
sig_base_string :: ByteString -> ByteString -> ByteString -> ByteString
sig_base_string ps method url = build $ (bs method) <> amp <> url' <> amp <> ps'
where
amp = bs "&"
url' = bs $ percent_encode url
ps' = bs $ percent_encode ps
signing_key :: ByteString -> Maybe ByteString -> ByteString
signing_key secret token = build $ (bs secret) <> (bs "&") <> token' where
token' = bs $ maybe "" id token
sign
:: ByteString
-> ByteString
-> ByteString
sign key msg = B64.encode $ hmac hash 64 key msg
create_header_string :: [Param] -> ByteString
create_header_string params = build $ (bs "OAuth ") <> str where
q = bs $ pack ['"']
encoded = sort $ map percent_encode params
stringified = map (\(Param k v) -> (bs k) <> (bs "=") <> q <> (bs v) <> q)
encoded
comma'd = intersperse (bs ", ") stringified
str = foldl (<>) mempty comma'd
oauth_sig
:: MonadIO m
=> Credentials
-> ByteString
-> ByteString
-> [Param]
-> m [Param]
oauth_sig creds method url extras = do
nonce <- gen_nonce
ts <- timestamp >>= return . pack . show
let params = [ Param "oauth_consumer_key" (consumerKey creds)
, Param "oauth_nonce" nonce
, Param "oauth_timestamp" ts
, Param "oauth_token" (maybe "" id (token creds))
, Param "oauth_signature_method" "HMAC-SHA1"
, Param "oauth_version" "1.0"
]
let sk = signing_key (consumerSecret creds) (tokenSecret creds)
let params' = param_string $ extras ++ params
let base_string = sig_base_string params' method url
let signature = sign sk base_string
return $ (Param "oauth_signature" signature) : (params ++ extras)
auth_header
:: MonadIO m
=> Credentials
-> ByteString
-> ByteString
-> [Param]
-> m ByteString
auth_header (Credentials key secret token token_secret) method url extras = do
nonce <- gen_nonce
ts <- timestamp >>= return . pack . show
let params = [ Param "oauth_consumer_key" key
, Param "oauth_nonce" nonce
, Param "oauth_timestamp" ts
, Param "oauth_token" (maybe "" id token)
, Param "oauth_signature_method" "HMAC-SHA1"
, Param "oauth_version" "1.0"
]
let sk = signing_key secret token_secret
let params' = param_string $ extras ++ params
let base_string = sig_base_string params' method url
let signature = sign sk base_string
let with_signature = (Param "oauth_signature" signature) : params
return $ create_header_string with_signature