module Web.Authenticate.OAuth
(
OAuth(..), SignMethod(..), Credential(..),
emptyCredential, insert, delete, inserts,
signOAuth, genSign,
authorizeUrl, getAccessToken, getTemporaryCredential,
getTokenCredential,
paramEncode
) where
import Network.HTTP.Enumerator
import Web.Authenticate.Internal (qsUrl)
import Data.Data
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.Maybe
import Control.Applicative
import Network.HTTP.Types (parseSimpleQuery)
import Control.Exception
import Control.Monad
import Data.List (sortBy)
import System.Random
import Data.Char
import Data.Digest.Pure.SHA
import Data.ByteString.Base64
import Data.Time
import Numeric
import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))
import Network.HTTP.Types (Header)
import Control.Arrow (second)
import Blaze.ByteString.Builder (toByteString)
import Data.Enumerator (($$), run_, Stream (..), continue)
import Data.Monoid (mconcat)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.IORef (newIORef, readIORef, atomicModifyIORef)
data OAuth = OAuth { oauthServerName :: String
, oauthRequestUri :: String
, oauthAccessTokenUri :: String
, oauthAuthorizeUri :: String
, oauthSignatureMethod :: SignMethod
, oauthConsumerKey :: BS.ByteString
, oauthConsumerSecret :: BS.ByteString
, oauthCallback :: Maybe BS.ByteString
} deriving (Show, Eq, Ord, Read, Data, Typeable)
data SignMethod = PLAINTEXT
| HMACSHA1
| RSASHA1 PrivateKey
deriving (Show, Eq, Ord, Read, Data, Typeable)
deriving instance Typeable PrivateKey
deriving instance Data PrivateKey
deriving instance Read PrivateKey
deriving instance Ord PrivateKey
deriving instance Eq PrivateKey
data Credential = Credential { unCredential :: [(BS.ByteString, BS.ByteString)] }
deriving (Show, Eq, Ord, Read, Data, Typeable)
emptyCredential :: Credential
emptyCredential = Credential []
token, tokenSecret :: Credential -> BS.ByteString
token = fromMaybe "" . lookup "oauth_token" . unCredential
tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential
data OAuthException = ProtocolException String
deriving (Show, Eq, Data, Typeable)
instance Exception OAuthException
toStrict :: BSL.ByteString -> BS.ByteString
toStrict = BS.concat . BSL.toChunks
fromStrict :: BS.ByteString -> BSL.ByteString
fromStrict = BSL.fromChunks . return
getTemporaryCredential :: OAuth
-> IO Credential
getTemporaryCredential oa = do
let req = fromJust $ parseUrl $ oauthRequestUri oa
req' <- signOAuth oa emptyCredential (req { method = "POST" })
rsp <- withManager $ httpLbs req'
let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic
authorizeUrl :: OAuth
-> Credential
-> String
authorizeUrl oa cr = qsUrl (oauthAuthorizeUri oa) [("oauth_token", BS.unpack $ token cr)]
getAccessToken, getTokenCredential
:: OAuth
-> Credential
-> IO Credential
getAccessToken oa cr = do
let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }
rsp <- signOAuth oa cr req >>= withManager . httpLbs
let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic
getTokenCredential = getAccessToken
insertMap :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
insertMap key val = ((key,val):) . filter ((/=key).fst)
deleteMap :: Eq a => a -> [(a,b)] -> [(a,b)]
deleteMap k = filter ((/=k).fst)
insert :: BS.ByteString
-> BS.ByteString
-> Credential
-> Credential
insert k v = Credential . insertMap k v . unCredential
inserts :: [(BS.ByteString, BS.ByteString)] -> Credential -> Credential
inserts = flip $ foldr (uncurry insert)
delete :: BS.ByteString
-> Credential
-> Credential
delete key = Credential . deleteMap key . unCredential
signOAuth :: OAuth
-> Credential
-> Request IO
-> IO (Request IO)
signOAuth oa crd req = do
crd' <- addTimeStamp =<< addNonce crd
let tok = injectOAuthToCred oa crd'
sign <- genSign oa tok req
return $ addAuthHeader (insert "oauth_signature" sign tok) req
baseTime :: UTCTime
baseTime = UTCTime day 0
where
day = ModifiedJulianDay 40587
showSigMtd :: SignMethod -> BS.ByteString
showSigMtd PLAINTEXT = "PLAINTEXT"
showSigMtd HMACSHA1 = "HMAC-SHA1"
showSigMtd (RSASHA1 _) = "RSA-SHA1"
addNonce :: Credential -> IO Credential
addNonce cred = do
nonce <- replicateM 10 (randomRIO ('a','z'))
return $ insert "oauth_nonce" (BS.pack nonce) cred
addTimeStamp :: Credential -> IO Credential
addTimeStamp cred = do
stamp <- floor . (`diffUTCTime` baseTime) <$> getCurrentTime :: IO Integer
return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred
injectOAuthToCred :: OAuth -> Credential -> Credential
injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa) $
inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa)
, ("oauth_consumer_key", oauthConsumerKey oa)
, ("oauth_version", "1.0")
] cred
genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString
genSign oa tok req =
case oauthSignatureMethod oa of
HMACSHA1 -> do
text <- getBaseString tok req
let key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text
PLAINTEXT ->
return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
RSASHA1 pr ->
liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)
addAuthHeader :: Credential -> Request a -> Request a
addAuthHeader (Credential cred) req =
req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req }
renderAuthHeader :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString
renderAuthHeader = ("OAuth " `BS.append`). BS.intercalate "," . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""]) . filter ((`notElem` ["oauth_token_secret", "oauth_consumer_secret"]) . fst)
paramEncode :: BS.ByteString -> BS.ByteString
paramEncode = BS.concatMap escape
where
escape c | isAlpha c || isDigit c || c `elem` "-._~" = BS.singleton c
| otherwise = let num = map toUpper $ showHex (ord c) ""
oct = '%' : replicate (2 length num) '0' ++ num
in BS.pack oct
getBaseString :: MonadIO m => Credential -> Request m -> m BSL.ByteString
getBaseString tok req = do
let bsMtd = BS.map toUpper $ method req
isHttps = secure req
scheme = if isHttps then "https" else "http"
bsPort = if (isHttps && port req /= 443) || (not isHttps && port req /= 80)
then ':' `BS.cons` BS.pack (show $ port req) else ""
bsURI = BS.concat [scheme, "://", host req, bsPort, path req]
bsQuery = map (second $ fromMaybe "") $ queryString req
bsBodyQ <- if isBodyFormEncoded $ requestHeaders req
then liftM parseSimpleQuery $ toLBS (requestBody req)
else return []
let bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).fst) $ unCredential tok
allParams = bsQuery++bsBodyQ++bsAuthParams
bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple
$ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams
return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
toLBS :: MonadIO m => RequestBody m -> m BS.ByteString
toLBS (RequestBodyLBS l) = return $ toStrict l
toLBS (RequestBodyBS s) = return s
toLBS (RequestBodyBuilder _ b) = return $ toByteString b
toLBS (RequestBodyEnum _ enum) = do
i <- liftIO $ newIORef id
run_ $ enum $$ go i
liftIO $ liftM (toByteString . mconcat . ($ [])) $ readIORef i
where
go i =
continue go'
where
go' (Chunks []) = continue go'
go' (Chunks x) = do
liftIO (atomicModifyIORef i $ \y -> (y . (x ++), ()))
continue go'
go' EOF = return ()
isBodyFormEncoded :: [Header] -> Bool
isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"
compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering
compareTuple (a,b) (c,d) =
case compare a c of
LT -> LT
EQ -> compare b d
GT -> GT