packages feed

authenticate-oauth (empty) → 0.1

raw patch · 5 files changed

+366/−0 lines, 5 filesdep +RSAdep +SHAdep +authenticatesetup-changed

Dependencies added: RSA, SHA, authenticate, base, base64-bytestring, bytestring, http-enumerator, random, time, utf8-string, wai, wai-extra

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/Authenticate/Internal.hs view
@@ -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
+ Web/Authenticate/OAuth.hs view
@@ -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
+ authenticate-oauth.cabal view
@@ -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:         +