diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Hiromi ISHII + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Hiromi ISHII nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs new file mode 100644 --- /dev/null +++ b/Web/Authenticate/Internal.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Web.Authenticate.Internal + ( qsEncode + , qsUrl + , AuthenticateException (..) + ) where + +import Codec.Binary.UTF8.String (encode) +import Numeric (showHex) +import Data.List (intercalate) +import Data.Typeable (Typeable) +import Control.Exception (Exception) + +data AuthenticateException = + RpxnowException String + | NormalizationException String + | DiscoveryException String + | AuthenticationException String + deriving (Show, Typeable) +instance Exception AuthenticateException + +qsUrl :: String -> [(String, String)] -> String +qsUrl s [] = s +qsUrl url pairs = + url ++ delim : intercalate "&" (map qsPair pairs) + where + qsPair (x, y) = qsEncode x ++ '=' : qsEncode y + delim = if '?' `elem` url then '&' else '?' + +qsEncode :: String -> String +qsEncode = + concatMap go . encode + where + go 32 = "+" -- space + go 46 = "." + go 45 = "-" + go 126 = "~" + go 95 = "_" + go c + | 48 <= c && c <= 57 = [w2c c] + | 65 <= c && c <= 90 = [w2c c] + | 97 <= c && c <= 122 = [w2c c] + go c = '%' : showHex c "" + w2c = toEnum . fromEnum diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs new file mode 100644 --- /dev/null +++ b/Web/Authenticate/OAuth.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Web.Authenticate.OAuth + ( -- * Data types + OAuth(..), SignMethod(..), Credential(..), + -- * Operations for credentials + emptyCredential, insert, delete, inserts, + -- * Signature + signOAuth, + -- * Url & operation for authentication + authorizeUrl, getTokenCredential, getTemporaryCredential, + -- * Utility Methods + 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.Wai.Parse +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 Network.Wai (ResponseHeader) +import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..)) + + +-- | Data type for OAuth client (consumer). +data OAuth = OAuth { oauthServerName :: String -- ^ Service name + , oauthRequestUri :: String -- ^ URI to request temporary credential + , oauthAccessTokenUri :: String -- ^ Uri to obtain access token + , oauthAuthorizeUri :: String -- ^ Uri to authorize + , oauthSignatureMethod :: SignMethod -- ^ Signature Method + , oauthConsumerKey :: BS.ByteString -- ^ Consumer key + , oauthConsumerSecret :: BS.ByteString -- ^ Consumer Secret + , oauthCallback :: Maybe BS.ByteString -- ^ Callback uri to redirect after authentication + } deriving (Show, Eq, Ord, Read, Data, Typeable) + + +-- | Data type for signature method. +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 type for redential. +data Credential = Credential { unCredential :: [(BS.ByteString, BS.ByteString)] } + deriving (Show, Eq, Ord, Read, Data, Typeable) + +-- | Empty credential. +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 + +-- | Get temporary credential for requesting acces token. +getTemporaryCredential :: OAuth -- ^ OAuth Application + -> IO Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredential oa = do + let req = fromJust $ parseUrl (oauthRequestUri oa) + req' <- signOAuth oa emptyCredential (req { method = "POST" }) + rsp <- httpLbs req' + let dic = parseQueryString . toStrict . responseBody $ rsp + return $ Credential dic + +-- | URL to obtain OAuth verifier. +authorizeUrl :: OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential (Request Token & Secret) + -> String -- ^ URL to authorize +authorizeUrl oa cr = qsUrl (oauthAuthorizeUri oa) [("oauth_token", BS.unpack $ token cr)] + +-- | Get Token Credential (Access token & secret). +getTokenCredential :: OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> IO Credential -- ^ Token Credential (Access Token & Secret) +getTokenCredential oa cr = do + let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } + rsp <- signOAuth oa cr req >>= httpLbs + let dic = parseQueryString . toStrict . responseBody $ rsp + return $ Credential dic + +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 an oauth parameter into given 'Credential'. +insert :: BS.ByteString -- ^ Parameter Name + -> BS.ByteString -- ^ Value + -> Credential -- ^ Credential + -> Credential -- ^ Result +insert k v = Credential . insertMap k v . unCredential + +-- | Convenient method for inserting multiple parameters into credential. +inserts :: [(BS.ByteString, BS.ByteString)] -> Credential -> Credential +inserts = flip $ foldr (uncurry insert) + +-- | Remove an oauth parameter for key from given 'Credential'. +delete :: BS.ByteString -- ^ Parameter name + -> Credential -- ^ Credential + -> Credential -- ^ Result +delete key = Credential . deleteMap key . unCredential + +-- | Add OAuth headers & sign to 'Request'. +signOAuth :: OAuth -- ^ OAuth Application + -> Credential -- ^ Credential + -> Request -- ^ Original Request + -> IO Request -- ^ Signed OAuth Request +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) + ] cred + +genSign :: OAuth -> Credential -> Request -> BS.ByteString +genSign oa tok req = + case oauthSignatureMethod oa of + HMACSHA1 -> + let text = getBaseString tok req + key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] + in encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text + PLAINTEXT -> + BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] + RSASHA1 pr -> + encode $ toStrict $ rsassa_pkcs1_v1_5_sign ha_SHA1 pr (getBaseString tok req) + +addAuthHeader :: Credential -> Request -> Request +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) + +-- | Encode a string using the percent encoding method for OAuth. +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 :: Credential -> Request -> BSL.ByteString +getBaseString tok req = + 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 = queryString req + bsBodyQ = if isBodyFormEncoded $ requestHeaders req + then parseQueryString (toStrict $ requestBody req) else [] + bsAuthParams = filter ((`notElem`["oauth_signature","realm","oauth_version", "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 + in BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] + +isBodyFormEncoded :: [(ResponseHeader, BS.ByteString)] -> 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 diff --git a/authenticate-oauth.cabal b/authenticate-oauth.cabal new file mode 100644 --- /dev/null +++ b/authenticate-oauth.cabal @@ -0,0 +1,68 @@ +-- authenticate-oauth.cabal auto-generated by cabal init. For +-- additional options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: authenticate-oauth + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1 + +-- A short (one-line) description of the package. +Synopsis: OAuth client support for authenticate package. + +-- A longer description of the package. +Description: OAuth client support for authenticate package. + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Hiromi ISHII + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: konn.jinro_at_gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Web + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.2 + +Library + -- Modules exported by the library. + Exposed-modules: Web.Authenticate.OAuth + + -- Packages needed in order to build this package. + Build-depends: base >= 4.0 && < 5.0, + bytestring >= 0.9 && < 1.0, + http-enumerator >= 0.3 && < 0.4, + wai >= 0.3 && < 0.4, utf8-string >= 0.3 && < 0.4, + authenticate >= 0.8 && < 0.9, + RSA >= 1.0 && < 1.1, + time >= 1.1 && < 1.2, + base64-bytestring >= 0.1 && < 0.2, + SHA >= 1.4 && < 1.5, + random >= 1.0 && < 1.1, + wai-extra >= 0.3 && < 0.4 + + + -- Modules not exported by this package. + Other-modules: Web.Authenticate.Internal + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: +