hoauth 0.1.9 → 0.2.0
raw patch · 10 files changed
+959/−398 lines, 10 filesdep +curldep +dataencdep +mtldep −RSAdep −base64-stringdep −system-uuid
Dependencies added: curl, dataenc, mtl, random
Dependencies removed: RSA, base64-string, system-uuid
Files
- hoauth.cabal +17/−10
- src/main/haskell/Network/OAuth/Consumer.hs +363/−0
- src/main/haskell/Network/OAuth/Http/HttpClient.hs +86/−0
- src/main/haskell/Network/OAuth/Http/PercentEncoding.hs +86/−0
- src/main/haskell/Network/OAuth/Http/Request.hs +325/−0
- src/main/haskell/Network/OAuth/Http/Response.hs +47/−0
- src/main/haskell/Network/OAuth/Http/Util.hs +35/−0
- src/main/haskell/Network/Protocol/OAuth/Consumer.hs +0/−103
- src/main/haskell/Network/Protocol/OAuth/Request.hs +0/−172
- src/main/haskell/Network/Protocol/OAuth/Signature.hs +0/−113
hoauth.cabal view
@@ -1,36 +1,43 @@ name: hoauth-version: 0.1.9+version: 0.2.0 category: Network,Protocol,OAuth license: BSD3 license-file: LICENSE author: Diego Souza-maintainer: Diego Souza <dsouza@bitforest.org>+maintainer: Diego Souza <dsouza at bitforest.org> stability: experimental build-type: Simple cabal-version: >= 1.6-tested-with: GHC==6.10.4+tested-with: GHC==6.12.1 synopsis: A Haskell implementation of OAuth 1.0a protocol. description: This library implements all PLAINTEXT, HMAC-SHA1 and RSA-SHA1 signatures as defined in the specification 1.0. Currently it supports only /consumer/ related functions, but there are plans to add support /service providers/ as well. - More info at: <http://oauth.net/>+ More on OAuth protocol info at: <http://oauth.net/> library build-depends: base<5 ,bytestring+ ,binary ,SHA- ,RSA- ,base64-string+ ,dataenc ,utf8-string- ,binary ,time ,old-locale- ,system-uuid- exposed-modules: Network.Protocol.OAuth.Consumer,Network.Protocol.OAuth.Request,Network.Protocol.OAuth.Signature+ ,random+ ,curl+ ,mtl+ exposed-modules: Network.OAuth.Http.Request+ ,Network.OAuth.Http.Response+ ,Network.OAuth.Http.HttpClient+ ,Network.OAuth.Http.PercentEncoding+ ,Network.OAuth.Http.Util+ ,Network.OAuth.Consumer+ hs-source-dirs: src/main/haskell- ghc-options: -Wall -fwarn-tabs+ ghc-options: -W -Wall -fwarn-tabs source-repository head type: darcs
+ src/main/haskell/Network/OAuth/Consumer.hs view
@@ -0,0 +1,363 @@+-- Copyright (c) 2009, Diego Souza+-- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.++-- | A Haskell library that implements oauth authentication protocol as defined in <http://tools.ietf.org/html/draft-hammer-oauth-10>.+-- +-- According to the RFC [1]:+-- OAuth provides a method for clients to access server resources on behalf+-- of a resource owner (such as a different client or an end- user). It also+-- provides a process for end-users to authorize third- party access to their+-- server resources without sharing their credentials (typically, a username and+-- password pair), using user- agent redirections.+-- +-- The following code should perform a request using 3 legged oauth, provided the parameters are defined correctly:+-- +-- > reqUrl = fromJust . parseURL $ "https://service.provider/request_token"+-- > accUrl = fromJust . parseURL $ "https://service.provider/access_token"+-- > srvUrl = fromJust . parseURL $ "http://service/path/to/resource/"+-- > authUrl = ("http://service.provider/authorize?oauth_token="++) . findWithDefault ("oauth_token","") . oauthParams+-- > app = Application "consumerKey" "consumerSec" OOB+-- > response = runOAuth $ do ignite app+-- > oauthRequest PLAINTEXT Nothing reqUrl+-- > cliAskAuthorization authUrl+-- > oauthRequest PLAINTEXT Nothing accUrl+-- > serviceRequest HMACSHA1 (Just "realm") srvUrl+--+module Network.OAuth.Consumer (+ -- * Types+ Token(application,oauthParams)+ ,Application(..)+ ,OAuthCallback(..)+ ,SigMethod(..)+ ,Realm+ ,Nonce+ ,Timestamp+ ,OAuthMonad+ -- * OAuthMonad related functions+ ,runOAuth+ ,oauthRequest+ ,serviceRequest+ ,cliAskAuthorization+ ,ignite+ ,getToken+ ,putToken+ -- * Token related functions+ ,twoLegged+ ,threeLegged+ ,signature+ ,injectOAuthVerifier+ ,fromApplication+ ,fromResponse+ ,authorization+ ) where++import Network.OAuth.Http.HttpClient+import Network.OAuth.Http.Request+import Network.OAuth.Http.Response+import Network.OAuth.Http.PercentEncoding+import Control.Monad.State+import System.Random (randomRIO)+import Data.Time (getCurrentTime,formatTime)+import System.Locale (defaultTimeLocale)+import Data.Char (chr,ord)+import Data.List (intercalate,sort)+import System.IO+import qualified Data.Binary as Bi+import Data.Word (Word8)+import qualified Data.Digest.Pure.SHA as S+import qualified Codec.Binary.Base64 as B64+import qualified Data.ByteString.Lazy as B++-- | Random string that is unique amongst requests. Refer to <http://oauth.net/core/1.0/#nonce> for more information.+type Nonce = String++-- | Unix timestamp (seconds since epoch). Refer to <http://oauth.net/core/1.0/#nonce> for more information.+type Timestamp = String++-- | The optional authentication realm. Refer to <http://oauth.net/core/1.0/#auth_header_authorization> for more information.+type Realm = String++-- | Callback used in oauth authorization+data OAuthCallback = URL String+ | OOB+ deriving (Eq)++-- | Identifies the application.+data Application = Application { consKey :: String + , consSec :: String+ , callback :: OAuthCallback+ }+ deriving (Show,Eq)++-- | The OAuth Token.+data Token = + {-| There is no valid token present, all requests go unauthenticated.+ -}+ TwoLegg {application :: Application + ,oauthParams :: FieldList+ }+ {-| The request token is a 2 legged OAuth. At this point, the service+ provider has validated your application.+ -}+ | ReqToken {application :: Application+ ,oauthParams :: FieldList+ }+ {-| This is a proper 3 legged OAuth. The difference between this and ReqToken+ is that user has authorized your application and you can perform requests+ on behalf of that user.+ -}+ | AccessToken {application :: Application+ ,oauthParams :: FieldList+ }+ deriving (Eq)++-- | Available signature methods.+data SigMethod = + {-| The 'PLAINTEXT' /consumer_key/ /token_secret/ method does not provide+ any security protection and SHOULD only be used over a secure channel+ such as /HTTPS/. It does not use the Signature Base String.+ -}+ PLAINTEXT+ {-| The 'HMAC_SHA1' /consumer_key/ /token_secret/ signature method uses the+ /HMAC-SHA1/ signature algorithm as defined in+ <http://tools.ietf.org/html/rfc2104> where the Signature Base String is+ the text and the key is the concatenated values (each first encoded per+ Parameter Encoding) of the Consumer Secret and Token Secret, separated+ by an /&/ character (ASCII code 38) even if empty.+ -}+ | HMACSHA1++-- | The OAuth monad.+type OAuthMonad m a = StateT Token m a++-- | Signs a request using a given signature method. This expects the request+-- to be a valid request already (for instance, none and timestamp are not set).+signature :: SigMethod -> Token -> Request -> String+signature m token req = case m+ of PLAINTEXT -> key+ HMACSHA1 -> b64encode $ S.bytestringDigest (S.hmacSha1 (bsencode key) (bsencode text))+ where bsencode = B.pack . map (fromIntegral.ord)+ b64encode = B64.encode . B.unpack++ key = encode (consSec (application token)) + ++"&"++ + encode (findWithDefault ("oauth_token_secret","") (oauthParams token))++ text = intercalate "&" $ map encode [show (method req)+ ,showURL (req {qString = empty})+ ,intercalate "&" . map (\(k,v) -> k++"="++v)+ . sort+ . map (\(k,v) -> (encode k,encode v)) + . toList + $ params+ ]++ params = if (ifindWithDefault ("content-type","") (reqHeaders req) == "application/x-www-form-urlencoded")+ then (qString req) `unionAll` (parseQString . map (chr.fromIntegral) + . B.unpack + . reqPayload $ req)+ else qString req++-- | Returns true if the token is able to perform 2-legged oauth requests.+twoLegged :: Token -> Bool+twoLegged (TwoLegg _ _) = True+twoLegged _ = False++-- | Tests whether or not the current token is able to perform 3-legged requests.+threeLegged :: Token -> Bool+threeLegged (AccessToken _ _) = True+threeLegged _ = False++-- | Transforms an application into a token.+ignite :: (MonadIO m) => Application -> OAuthMonad m ()+ignite = put . fromApplication++-- | Transforms an application into a token+fromApplication :: Application -> Token+fromApplication app = TwoLegg app empty++-- | Execute the oauth monad and returns the value it produced.+runOAuth :: (MonadIO m,HttpClient m) => OAuthMonad m a -> m a+runOAuth = flip evalStateT (TwoLegg (Application "" "" OOB) empty)++-- | Executes an oauth request which is intended to upgrade/refresh the current+-- token. Use this combinator to get either a request token or an access+-- token.+oauthRequest :: (MonadIO m,HttpClient m) => SigMethod -> Maybe Realm -> Request -> OAuthMonad m (Either String Token)+oauthRequest sigm realm req = do response <- serviceRequest sigm realm req+ token <- get+ case (fromResponse response token)+ of (Right token') -> do put token'+ return (Right token')+ (Left err) -> return (Left err)++-- | Performs a signed request with the available token.+serviceRequest :: (MonadIO m,HttpClient m) => SigMethod -> Maybe Realm -> Request -> OAuthMonad m Response+serviceRequest sigm realm req = do nonce <- _nonce+ timestamp <- _timestamp+ token <- get+ + let authValue = authorization sigm realm nonce timestamp token req+ lift (request (req {reqHeaders = insert ("Authorization",authValue) (reqHeaders req)}))++-- | Extracts the token from the OAuthMonad.+getToken :: (Monad m) => OAuthMonad m Token+getToken = get++-- | Alias to the put function.+putToken :: (Monad m) => Token -> OAuthMonad m ()+putToken = put++-- | Injects the oauth_verifier into the token. Usually this means the user has+-- authorized the app to access his data.+injectOAuthVerifier :: String -> Token -> Token+injectOAuthVerifier value (ReqToken app params) = ReqToken app (replace ("oauth_verifier",value) params)+injectOAuthVerifier _ token = token++-- | Probably this is just useful for testing. It asks the user (stdout/stdin)+-- to authorize the application and provide the oauth_verifier.+cliAskAuthorization :: (MonadIO m) => (Token -> String) -> OAuthMonad m ()+cliAskAuthorization getUrl = do token <- get+ answer <- liftIO $ do hSetBuffering stdout NoBuffering+ putStrLn ("open " ++ (getUrl token))+ putStr "oauth_verifier: "+ getLine+ put (injectOAuthVerifier answer token)++-- | Receives a response possibly from a service provider and updates the+-- token. As a matter effect, assumes the content-type is+-- application/x-www-form-urlencoded (because some service providers send it as+-- text/plain) and if the status is [200..300) updates the token accordingly.+fromResponse :: Response -> Token -> Either String Token+fromResponse rsp token | validRsp = case (token)+ of (TwoLegg app params) -> Right $ ReqToken app (payload `union` params)+ (ReqToken app params) -> Right $ AccessToken app (payload `union` params)+ (AccessToken app params) -> Right $ AccessToken app (payload `union` params)+ | otherwise = Left (statusLine rsp)+ where payload = parseQString . map (chr.fromIntegral) . B.unpack . rspPayload $ rsp++ validRsp = statusOk && paramsOk++ statusOk = status rsp `elem` [200..299]++ paramsOk = not $ null (zipWithM ($) (map (find . (==)) requiredKeys) (repeat payload))++ requiredKeys = case token+ of (TwoLegg _ _) -> ["oauth_token"+ ,"oauth_token_secret"+ ,"oauth_callback_confirmed"+ ]+ _ -> ["oauth_token"+ ,"oauth_token_secret"+ ]++-- | Computes the authorization header and updates the request.+authorization :: SigMethod -> Maybe Realm -> Nonce -> Timestamp -> Token -> Request -> String+authorization m realm nonce time token req = oauthPrefix ++ enquote (("oauth_signature",oauthSignature):oauthFields)+ where oauthFields = [("oauth_consumer_key",consKey.application $ token)+ ,("oauth_nonce",nonce)+ ,("oauth_timestamp",time)+ ,("oauth_signature_method",show m)+ ,("oauth_version","1.0")+ ] ++ extra++ oauthPrefix = case realm+ of Nothing -> "OAuth "+ Just v -> "OAuth realm=\""++encode v++"\","++ extra = case token+ of (TwoLegg app _) -> [("oauth_callback",show.callback $ app)]+ (ReqToken _ params) -> filter (not.null.snd) [("oauth_verifier",findWithDefault ("oauth_verifier","") params)+ ,("oauth_token",findWithDefault ("oauth_token","") params)]+ (AccessToken _ params) -> filter (not.null.snd) [("oauth_token",findWithDefault ("oauth_token","") params)+ ,("oauth_session_handle",findWithDefault ("oauth_session_handle","") params)+ ]++ oauthSignature = signature m token (req {qString = (qString req) `union` (fromList oauthFields)})++ enquote = intercalate "," . map (\(k,v) -> encode k ++"=\""++ encode v ++"\"")++_nonce :: (MonadIO m) => m Nonce+_nonce = do rand <- liftIO (randomRIO (0,maxBound::Int))+ return (show rand)++_timestamp :: (MonadIO m) => m Timestamp+_timestamp = do clock <- liftIO getCurrentTime+ return (formatTime defaultTimeLocale "%s" clock)++instance Show SigMethod where+ showsPrec _ PLAINTEXT = showString "PLAINTEXT"+ showsPrec _ HMACSHA1 = showString "HMAC-SHA1"++instance Show OAuthCallback where+ showsPrec _ OOB = showString "oob"+ showsPrec _ (URL u) = showString u++instance Bi.Binary OAuthCallback where+ put OOB = Bi.put (0 :: Word8)+ put (URL url) = do Bi.put (1 :: Word8) + Bi.put url+ + get = do t <- Bi.get :: Bi.Get Word8+ case t+ of 0 -> return OOB+ 1 -> fmap URL Bi.get+ _ -> error "Consumer: parse error"++instance Bi.Binary Application where+ put app = do Bi.put (consKey app)+ Bi.put (consSec app)+ Bi.put (callback app)+ + get = do ckey <- Bi.get+ csec <- Bi.get+ callback_ <- Bi.get+ return (Application ckey csec callback_)++instance Bi.Binary Token where+ put (TwoLegg app params) = do Bi.put (0 :: Word8)+ Bi.put app+ Bi.put params+ put (ReqToken app params) = do Bi.put (1 :: Word8)+ Bi.put app+ Bi.put params+ put (AccessToken app params) = do Bi.put (2 :: Word8)+ Bi.put app+ Bi.put params+ get = do t <- Bi.get :: Bi.Get Word8+ case t + of 0 -> do app <- Bi.get+ params <- Bi.get+ return (TwoLegg app params)+ 1 -> do app <- Bi.get+ params <- Bi.get+ return (ReqToken app params)+ 2 -> do app <- Bi.get+ params <- Bi.get+ return (AccessToken app params)+ _ -> error "Consumer: parse error"++-- vim:sts=2:sw=2:ts=2:et
+ src/main/haskell/Network/OAuth/Http/HttpClient.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- Copyright (c) 2009, Diego Souza+-- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.++-- | A type class that is able to perform HTTP requests.+module Network.OAuth.Http.HttpClient (HttpClient(..)+ ,CurlM(..)+ ) where++import Network.Curl+import Control.Monad.Fix+import Control.Monad.Trans+import Network.OAuth.Http.Request+import Network.OAuth.Http.Response+import Data.Char (chr)+import qualified Data.ByteString.Lazy as B++-- | The HttpClient type class.+class (Monad m) => HttpClient m where+ -- | Performs the request and returns the response wrapped into a given monad.+ request :: Request -> m Response++-- | The libcurl backend+newtype CurlM a = CurlM { unCurlM :: IO a }+ deriving (Monad,MonadIO,MonadFix,Functor)+instance HttpClient CurlM where+ request req = CurlM $ withCurlDo $ do c <- initialize+ setopts c opts+ rsp <- perform_with_response_ c+ return $ RspHttp (respStatus rsp)+ (respStatusLine rsp)+ (fromList.respHeaders $ rsp)+ (respBody rsp)+ where httpVersion = case (version req)+ of Http10 -> HttpVersion10+ Http11 -> HttpVersion11+ + curlMethod = case (method req)+ of GET -> [CurlHttpGet True]+ POST -> [CurlPost True]+ PUT -> [CurlPut True]+ HEAD -> [CurlNoBody True,CurlCustomRequest "HEAD"]+ other -> if (B.null.reqPayload $ req)+ then [CurlHttpGet True,CurlCustomRequest (show other)]+ else [CurlPost True,CurlCustomRequest (show other)]+ curlPostData = if (B.null.reqPayload $ req)+ then []+ else [CurlPostFields [map (chr.fromIntegral).B.unpack.reqPayload $ req]]+ curlHeaders = let headers = (map (\(k,v) -> k++": "++v).toList.reqHeaders $ req)+ in [CurlHttpHeaders $"Expect: " + :("Content-Length: " ++ (show.B.length.reqPayload $ req))+ :headers+ ]++ opts = [CurlURL (showURL req)+ ,CurlHttpVersion httpVersion+ ,CurlHeader False+ ] ++ curlHeaders+ ++ curlMethod + ++ curlPostData+ +-- vim:sts=2:sw=2:ts=2:et
+ src/main/haskell/Network/OAuth/Http/PercentEncoding.hs view
@@ -0,0 +1,86 @@+-- Copyright (c) 2009, Diego Souza+-- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.++-- | Percent encoding <http://tools.ietf.org/html/rfc3986#page-12> functions,+-- with the exception that all encoding/decoding is in UTF-8.+module Network.OAuth.Http.PercentEncoding (PercentEncoding(..)+ ,decodeWithDefault+ ) where++import Data.Monoid (mappend)+import Data.List (splitAt)+import qualified Codec.Binary.UTF8.String as U+import Data.Char (intToDigit,digitToInt,toUpper,ord)+import Data.Bits++class PercentEncoding a where+ -- | Encodes a type into its percent encoding representation.+ encode :: a -> String++ -- | Decodes a percent-encoded type to its native type.+ decode :: String -> Maybe (a,String)++-- | Encodes Char types using UTF\-8 charset.+instance PercentEncoding Char where+ encode c | c `elem` whitelist = [c]+ | otherwise = concatMap (run.fromIntegral) (U.encode [c])+ where whitelist = ['a'..'z'] + ++ ['A'..'Z']+ ++ ['0'..'9']+ ++ "-._~"+ run b = '%' : map (toUpper.intToDigit) [shiftR (b .&. 0xF0) 4,b .&. 0x0F]++ decode xs = case (U.decode . tobytes $ xs)+ of [] -> Nothing+ (y:_) -> let sizeof = if ("%"==take 1 xs)+ then length (encode y)+ else 1+ in Just (y,drop sizeof xs)+ where tobytes (b:bs) = case b + of '%' -> let ([c0,c1],bs') = splitAt 2 bs+ b0 = (shiftL (digitToInt c0) 4) .&. 0xF0+ b1 = (digitToInt c1) .&. 0x0F+ byte = fromIntegral (b0 .|. b1)+ in byte : tobytes bs'+ _ -> fromIntegral (ord b) : tobytes bs+ tobytes [] = []++-- | Add support for encoding strings+instance (PercentEncoding a) => PercentEncoding [a] where+ encode (x:xs) = encode x ++ encode xs+ encode [] = []+ + decode xs = do (c,ys) <- (decode xs)+ cs <- fmap (fst) (decode ys `mappend` Just ([],""))+ return (c:cs,"")++-- | Decodes a percent encoded string. In case of failure returns a default value, instead of Nothing.+decodeWithDefault :: (PercentEncoding a) => a -> String -> a+decodeWithDefault def str = case (decode str)+ of Just (v,"") -> v+ _ -> def++-- vim:sts=2:sw=2:ts=2:et
+ src/main/haskell/Network/OAuth/Http/Request.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- Copyright (c) 2009, Diego Souza+-- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.++-- | The request currently is only able to represent an HTTP request.+module Network.OAuth.Http.Request (+ -- * Types+ Request(..)+ ,FieldList()+ ,Version(..)+ ,Method(..)+ -- * FieldList related functions+ ,fromList+ ,singleton+ ,empty+ ,toList+ ,parseQString+ ,find+ ,findWithDefault+ ,ifindWithDefault+ ,change+ ,insert+ ,replace+ ,replaces+ ,union+ ,unionAll+ -- * Request related functions+ ,showURL+ ,showQString+ ,showProtocol+ ,showAuthority+ ,showPath+ ,parseURL+ ) where++import Control.Monad.State+import Network.OAuth.Http.PercentEncoding+import Network.OAuth.Http.Util+import Data.List (intercalate,isPrefixOf)+import Data.Monoid+import Data.Char (toLower)+import qualified Data.ByteString.Lazy as B+import qualified Data.Binary as Bi++-- | All known HTTP methods+data Method = GET+ | POST+ | PUT+ | DELETE+ | TRACE+ | CONNECT+ | HEAD+ deriving (Eq)++-- | Supported HTTP versions+data Version = Http10+ | Http11+ deriving (Eq)++-- | Key-value list.+newtype FieldList = FieldList {unFieldList :: [(String,String)]}+ deriving (Eq,Ord)++data Request = ReqHttp {version :: Version -- ^ Protocol version+ ,ssl :: Bool -- ^ Wheter or not to use ssl+ ,host :: String -- ^ The hostname to connect to+ ,port :: Int -- ^ The port to connect to+ ,method :: Method -- ^ The HTTP method of the request.+ ,reqHeaders :: FieldList -- ^ Request headers+ ,pathComps :: [String] -- ^ The path split into components + ,qString :: FieldList -- ^ The query string, usually set for GET requests+ ,reqPayload :: B.ByteString -- ^ The message body+ }+ deriving (Eq,Show)++-- | Show the protocol in use (currently either https or http)+showProtocol :: Request -> String+showProtocol req | ssl req = "https"+ | otherwise = "http"++-- | Show the host+port path of the request. May return only the host when+-- (ssl=False && port==80) or (ssl=True && port==443).+showAuthority :: Request -> String+showAuthority req | ssl req && (port req)==443 = host req+ | not (ssl req) && (port req)==80 = host req+ | otherwise = host req ++":"++ show (port req)++-- | Show the path component of the URL.+showPath :: Request -> String+showPath = intercalate "/" . map encode . pathComps++-- | Show the querty string of the URL.+showQString :: Request -> String+showQString = show . qString++-- | Show the URL.+showURL :: Request -> String+showURL = concat + . zipWith ($) [showProtocol,const "://",showAuthority,showPath,showQString'] + . repeat+ where showQString' :: Request -> String+ showQString' req | null (unFieldList (qString req)) = ""+ | otherwise = '?' : showQString req++-- | Parse a URL and creates an request type.+parseURL :: String -> Maybe Request+parseURL tape = evalState parser (tape,Just initial)+ where parser = do _parseProtocol+ _parseSymbol (':',True)+ _parseSymbol ('/',True)+ _parseSymbol ('/',True)+ _parseHost+ _parseSymbol (':',False)+ _parsePort+ _parseSymbol ('/',True)+ _parsePath+ _parseSymbol ('?',False)+ _parseQString+ fmap snd get+ initial = ReqHttp {version = Http11+ ,ssl = False+ ,method = GET+ ,host = "127.0.0.1"+ ,port = 80+ ,reqHeaders = fromList []+ ,pathComps = []+ ,qString = fromList []+ ,reqPayload = B.empty+ }++-- | Parse a query string.+parseQString :: String -> FieldList+parseQString tape = evalState parser (tape,Just initial)+ where parser = do _parseQString+ (fmap (qstring . snd) get)++ qstring Nothing = fromList []+ qstring (Just r) = qString r++ initial = ReqHttp {version = Http11+ ,ssl = False+ ,method = GET+ ,host = "127.0.0.1"+ ,port = 80+ ,reqHeaders = fromList []+ ,pathComps = []+ ,qString = fromList []+ ,reqPayload = B.empty+ }++-- | Creates a FieldList type from a list.+fromList :: [(String,String)] -> FieldList+fromList = FieldList++-- | Transforms a fieldlist into a list type.+toList :: FieldList -> [(String,String)]+toList = unFieldList++-- | Creates a FieldList out from a single element.+singleton :: (String,String) -> FieldList+singleton = fromList . (:[])++-- | Returns an empty fieldlist.+empty :: FieldList+empty = fromList []++-- | Updates all occurrences of a given key with a new value. Does nothing if+-- the values does not exist.+change :: (String,String) -> FieldList -> FieldList+change kv (FieldList list) = FieldList (change' kv list)+ where change' (k,v) ((k0,v0):fs) | k0==k = (k0,v) : change' (k,v) fs+ | otherwise = (k0,v0) : change' (k,v) fs+ change' _ [] = []++-- | Inserts a new value into a fieldlist.+insert :: (String,String) -> FieldList -> FieldList+insert kv = mappend (FieldList [kv])++-- | Inserts or updates occurrences of a given key.+replace :: (String,String) -> FieldList -> FieldList+replace (k,v) fs | null $ find (==k) fs = insert (k,v) fs+ | otherwise = change (k,v) fs++-- | Same as /replace/ but work on a list type+replaces :: [(String,String)] -> FieldList -> FieldList+replaces fs field = foldr (replace) field fs++-- | Find keys that satisfy a given predicate.+find :: (String -> Bool) -> FieldList -> [String]+find p (FieldList list) = map snd (filter (p.fst) list)++-- | Combines two fieldsets, but prefere items of the first list.+union :: FieldList -> FieldList -> FieldList+union (FieldList as) bs = foldr replace bs as++-- | Combines two fieldsets keeping duplicates.+unionAll :: FieldList -> FieldList -> FieldList+unionAll (FieldList as) bs = foldr insert bs as++-- | Finds a the value defined in a fieldlist or returns a default value. In+-- the event there are multiple values under the same key the first one is+-- returned.+findWithDefault :: (String,String) -> FieldList -> String+findWithDefault (key,def) fields | null values = def+ | otherwise = head values+ where values = find (==key) fields++-- | Same as <findWithDefault> but the match is case-insenstiive.+ifindWithDefault :: (String,String) -> FieldList -> String+ifindWithDefault (key,def) fields | null values = def+ | otherwise = head values+ where values = find (\k -> lower k == lower key) fields+ lower = map toLower++_parseProtocol :: State (String,Maybe Request) ()+_parseProtocol = get >>= \(tape,req) ->+ if ("https" `isPrefixOf` tape)+ then put (drop 5 tape,liftM (\r -> r {ssl=True,port=443}) req)+ else if ("http" `isPrefixOf` tape) + then put (drop 4 tape,liftM (\r -> r {ssl=False,port=80}) req)+ else put ("",Nothing)++_parseHost :: State (String,Maybe Request) ()+_parseHost = get >>= \(tape,req) ->+ let (value,tape') = break (`elem` ":/") tape+ in put (tape',liftM (\r -> r {host = value}) req)++_parsePort :: State (String,Maybe Request) ()+_parsePort = get >>= \(tape,req) ->+ let (value,tape') = break (=='/') tape+ in case (reads value)+ of [(value',"")] -> put (tape',liftM (\r -> r {port = value'}) req)+ _ -> put (tape',req)++_parsePath :: State (String,Maybe Request) ()+_parsePath = get >>= \(tape,req) ->+ let (value,tape') = break (=='?') tape+ value' = "" : map (decodeWithDefault "") (splitBy (=='/') value)+ in put (tape',liftM (\r -> r {pathComps=value'}) req)++_parseQString :: State (String,Maybe Request) ()+_parseQString = get >>= \(tape,req) ->+ let (value,tape') = break (=='#') tape+ fields = fromList $ filter (/=("","")) (map parseField (splitBy (=='&') value))+ in put (tape',liftM (\r -> r {qString=fields}) req)+ where parseField tape = let (k,v) = break (=='=') tape+ in case (v)+ of ('=':v') -> (decodeWithDefault "" k,decodeWithDefault "" v')+ _ -> (decodeWithDefault "" k,"")++_parseSymbol :: (Char,Bool) -> State (String,Maybe Request) ()+_parseSymbol (c,required) = get >>= \(tape,req) ->+ if ([c] `isPrefixOf` tape)+ then put (drop 1 tape,req)+ else if (required) + then put ("",Nothing)+ else put (tape,req)++instance Show Method where+ showsPrec _ m = case m + of GET -> showString "GET"+ POST -> showString "POST"+ DELETE -> showString "DELETE"+ CONNECT -> showString "CONNECT"+ HEAD -> showString "HEAD"+ TRACE -> showString "TRACE"+ PUT -> showString "PUT"++instance Read Method where+ readsPrec _ "GET" = [(GET,"")]+ readsPrec _ "POST" = [(POST,"")]+ readsPrec _ "DELETE" = [(DELETE,"")]+ readsPrec _ "CONNECT" = [(CONNECT,"")]+ readsPrec _ "HEAD" = [(HEAD,"")]+ readsPrec _ "TRACE" = [(TRACE,"")]+ readsPrec _ "PUT" = [(PUT,"")]+ readsPrec _ _ = []++instance Read Version where+ readsPrec _ "HTTP/1.0" = [(Http10,"")]+ readsPrec _ "HTTP/1.1" = [(Http11,"")]+ readsPrec _ _ = []++instance Show Version where+ showsPrec _ v = case v + of Http10 -> showString "HTTP/1.0"+ Http11 -> showString "HTTP/1.1"++instance Show FieldList where+ showsPrec _ = showString . intercalate "&" . map showField . unFieldList+ where showField (k,v) = encode k ++"="++ encode v++instance Monoid FieldList where+ mempty = FieldList []+ mappend (FieldList as) (FieldList bs) = FieldList (as `mappend` bs)++instance Bi.Binary FieldList where+ put = Bi.put . unFieldList+ get = fmap FieldList Bi.get++-- vim:sts=2:sw=2:ts=2:et
+ src/main/haskell/Network/OAuth/Http/Response.hs view
@@ -0,0 +1,47 @@+-- Copyright (c) 2009, Diego Souza+-- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.++-- | The response of the server for a given "Request". Similarly to "Request",+-- it is currently only able to represent HTTP responses.+module Network.OAuth.Http.Response (Response(..)+ ) where++import Data.ByteString.Lazy as B+import Network.OAuth.Http.Request (FieldList)++data Response = RspHttp {status :: Int -- ^ The status code (e.g. 200, 302)+ ,statusLine :: String -- ^ The message that comes along with the status (e.g. HTTP/1.1 200 OK)+ ,rspHeaders :: FieldList -- ^ The response headers+ ,rspPayload :: B.ByteString -- ^ The body of the message+ }+ deriving (Show)++-- contentType :: Response -> (String,FieldList)+-- contentType = let string = findWithDefault ("content-type","text/html") . rspHeaders+-- (type_,params) = break (==';') string+-- in (trim type_,trim charset)++-- vim:sts=2:sw=2:ts=2:et
+ src/main/haskell/Network/OAuth/Http/Util.hs view
@@ -0,0 +1,35 @@+-- Copyright (c) 2009, Diego Souza+-- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.++module Network.OAuth.Http.Util where++splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy = split (id)+ where split accum p (x:xs) | p x = (accum []) : split id p xs+ | otherwise = split (accum . (x:)) p xs+ split accum _ [] = [accum []]++-- vim:sts=2:sw=2:ts=2:et
− src/main/haskell/Network/Protocol/OAuth/Consumer.hs
@@ -1,103 +0,0 @@--- Copyright (c) 2009, Diego Souza--- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.---- | A pure library that implements oauth authentication protocol as defined in <http://oauth.net/core/1.0a>.------ Refer to <http://oauth.net/> for more information about the oauth protocol.-module Network.Protocol.OAuth.Consumer (Token(),Consumer(..),request,response,nonce_and_timestamp,oauth_token,oauth_token_secret,oauth_extra,plaintext_signature,hmacsha1_signature) where--import Network.Protocol.OAuth.Request as R-import qualified Data.ByteString.Lazy as B-import qualified Network.Protocol.OAuth.Signature as S-import qualified Data.Time.Clock as T-import qualified Data.Time.Format as F-import qualified System.Locale as L-import qualified System.UUID.V1 as U-import qualified Text.Printf as P-import qualified Data.Binary as Bn-import qualified Data.List as L-import qualified Control.Monad as M---- | OAuth uses Tokens generated by the Service Provider instead of the User's credentials in Protected Resources requests.-data Token = Token { oauth_token :: String,- oauth_token_secret :: String,- oauth_extra :: [R.Parameter]- }- deriving (Show,Read,Eq)---- | The application which needs to authenticate using oauth.-data Consumer = - -- | Creates a consumer with /consumer_key/ and /consumer_secret/- Unauthenticated String String- -- | A consumer with /consumer_key/, /consumer_secret/ and a 'Token'- | Authenticated String String Token- deriving (Show,Read,Eq)---- | The PLAINTEXT signature for a given consumer-plaintext_signature :: Consumer -> S.Method-plaintext_signature (Authenticated _ s t) = S.PLAINTEXT s ((Just . oauth_token_secret) t)-plaintext_signature (Unauthenticated _ s) = S.PLAINTEXT s Nothing---- | The HMAC-SHA1 signature for a given consumer -hmacsha1_signature :: Consumer -> S.Method-hmacsha1_signature (Authenticated _ s t) = S.HMAC_SHA1 s ((Just . oauth_token_secret) t)-hmacsha1_signature (Unauthenticated _ s) = S.HMAC_SHA1 s Nothing---- | Sign a request for oauth request. Use this either to sign requests with a proper Access token or to use the oauth protocol to get a token from service provider.------ The request you provide /must/ contain /oauth_nonce/ and /oauth_timestamp/ parameters properly defined.-request :: (S.Signer s,Show s) => Consumer -> s -> R.Request -> R.Request-request (Unauthenticated ckey _) s r = _oauth ckey s r-request (Authenticated ckey _ tk) s r = let req = r >>+ ("oauth_token", (Just . oauth_token) tk) - in _oauth ckey s req---- | Process the response of the service provider. The response should be an urlencoded string.-response :: Consumer -> B.ByteString -> Maybe Consumer-response c u = let postdata = R.read_urlencoded u- o_token = (M.join . lookup "oauth_token") postdata- o_token_sec = (M.join . lookup "oauth_token_secret") postdata- o_token_ext = return $ filter (not . flip elem ["oauth_token","oauth_token_secret"] . fst) postdata- token = M.liftM3 Token o_token o_token_sec o_token_ext- in case c- of (Unauthenticated ckey csec) -> M.liftM3 Authenticated (return ckey) (return csec) token- (Authenticated ckey csec _) -> M.liftM3 Authenticated (return ckey) (return csec) token---- | Generates the oauth_nonce and oauth_timestamp parameters.-nonce_and_timestamp :: Request -> IO Request-nonce_and_timestamp r = do- timestamp <- fmap (F.formatTime L.defaultTimeLocale "%s") T.getCurrentTime- nonce <- fmap (concatMap (P.printf "%02x") . B.unpack . Bn.encode) U.uuid- return (r >>+ ("oauth_nonce",Just nonce) >>+ ("oauth_timestamp",Just timestamp))--_oauth :: (S.Signer s,Show s) => String -> s -> R.Request -> R.Request-_oauth ckey met req = _sign met $ req >>+ ("oauth_consumer_key",Just ckey)- >>+ ("oauth_version",Just "1.0")- >>+ ("oauth_signature_method",(Just . show) met)--_sign :: (S.Signer s,Show s) => s -> R.Request -> R.Request-_sign met req = let sig = S.sign met req- in req >>+ ("oauth_signature",Just sig)-
− src/main/haskell/Network/Protocol/OAuth/Request.hs
@@ -1,172 +0,0 @@--- Copyright (c) 2009, Diego Souza--- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.--module Network.Protocol.OAuth.Request (Request(..),HTTPMethod(..),Parameter,PercentEncoding(encode,encodes,decode,decodes),append_param,show_url,show_oauthurl,show_oauthheader,show_urlencoded,read_urlencoded,(>>+)) where--import Data.Bits as B-import qualified Data.ByteString.Lazy as B-import qualified Codec.Binary.UTF8.String as S-import qualified Data.Word as W-import qualified Data.Char as C-import qualified Data.List as L---- | A pair which represents a parameter (key,value).-type Parameter = (String,Maybe String)---- | The possible HTTP methods-data HTTPMethod = GET- | POST- | DELETE- | PUT- deriving (Show,Read,Eq)---- | Refer to <http://en.wikipedia.org/wiki/Percent-encoding> for more information-class PercentEncoding a where- -- | Encodes an /a/ type to bytestring.- encode :: a -> B.ByteString- - -- | Encodes a list of /a/ types into bytestring.- encodes :: [a] -> B.ByteString- encodes = B.concat . map encode- - -- | Decodes a single /a/ type out of an encoded string.- decode :: B.ByteString -> (a,B.ByteString)- - -- | Decodes the whole string into a list of /a/ types.- decodes :: B.ByteString -> [a]- decodes = L.unfoldr decode'- where- decode' bs | B.null bs = Nothing- | otherwise = (Just . decode) bs---- | The HTTP request which must be properly authenticated with oauth. It is not meant to represent the full HTTP request, instead the data which matters for oauth authentication.-data Request = HTTP { ssl :: Bool, -- ^ True means /HTTPS/ and false means /HTTP/- method :: HTTPMethod,- host :: String, -- ^ The hostname or ip address (e.g. bitforest.org)- port :: Int, -- ^ The tcp port (e.g. 80)- path :: String, -- ^ The request path (e.g. \/foo\/bar\/)- params :: [Parameter] -- ^ The request parameters (both GET and POST)- }- deriving (Show,Read,Eq)---- | Convenience function to append an item in request's parameters list-append_param :: Request -> (String,Maybe String) -> Request-append_param r kv = let o_params = params r- n_params = kv : o_params- in r { params = n_params }---- | Parses a urlencoded string.-read_urlencoded :: B.ByteString -> [Parameter]-read_urlencoded u | B.null u = []- | otherwise = (map param' . map keyval' . B.split 0x26) u- where- keyval' s = let (k,v) = B.break (==0x3d) s- in (k, B.drop 1 v)-- param' (k,v) | B.null v = (decodes k,Nothing)- | otherwise = (decodes k,(Just . decodes) v)---- | Show the entire url, including possibly any oauth parameter which may be present.-show_url :: Request -> B.ByteString-show_url (HTTP s m h p0 p1 ps) = B.concat [endpoint', path', query']- where- endpoint' | s && p0==443 = B.pack $ S.encode $ "https://" ++ h- | s = B.pack $ S.encode $ "https://" ++ h ++ (':':(show p0))- | not s && p0==80 = B.pack $ S.encode $ "http://" ++ h- | otherwise = B.pack $ S.encode $ "http://" ++ h ++ (':':(show p0))-- path' = (B.cons 0x2f . B.concat . L.intersperse (B.singleton 0x2f) . map encodes . _path_comp) p1-- query' | m/=GET || null ps = B.empty- | otherwise = (B.cons 0x3f . show_urlencoded) ps---- | The URL to perform the oauth request-show_oauthurl :: Request -> B.ByteString-show_oauthurl req = let params' = params req- req' = req { params = filter (not . L.isPrefixOf "oauth_" . fst) params' }- in show_url req'---- | The Authorization or WWW-Authenticated headers to perform oauth authentication. -show_oauthheader :: String -- ^ The realm- -> Request- -> B.ByteString -- ^ The Authorization\/WWW-Authenticate header-show_oauthheader realm (HTTP _ _ _ _ _ p) | B.null params' = realm'- | otherwise = B.concat [realm', B.singleton 0x2c, params']- where- encodes' s = B.concat [B.singleton 0x22, encodes s, B.singleton 0x22]-- params' = (_urlencode encodes' 0x2c . filter (L.isPrefixOf "oauth_" . fst)) p-- realm' = B.pack $ S.encode ("OAuth realm=\"" ++ realm ++ "\"")---- | Produces a urlencoded string.--- For convenience, it sorts the parameters first, as demands the oauth protocol.-show_urlencoded :: [Parameter] -> B.ByteString-show_urlencoded = _urlencode encodes 0x26---- | Convenience operator to append an item in request's parameters list-(>>+) :: Request -> (String,Maybe String) -> Request-(>>+) = append_param--instance PercentEncoding Char where- encode = B.pack . concat . map enc' . S.encode . (:[])- where- enc' b | elem b whitelist' = [b]- | otherwise = let b0 = b .&. 0x0F- b1 = B.shiftR (b .&. 0xF0) 4- in ((37:) . map (fromIntegral . C.ord . C.toUpper . C.intToDigit . fromIntegral)) [b1,b0]- whitelist' = [0x61..0x7a] ++ [0x41..0x5a] ++ [0x30..0x39] ++ [0x2d,0x2e,0x5f,0x7e]-- decode bytes = let c0 = (head . decodes) bytes- b0 = encode c0- in (c0, B.drop (B.length b0) bytes)- - decodes = S.decode . fold' . B.unpack- where- fold' (37:b1:b0:bs) = let b1' = (fromIntegral . C.digitToInt . C.chr . fromIntegral) b1 - b0' = (fromIntegral . C.digitToInt . C.chr . fromIntegral) b0- bl = (B.shiftL b1' 4) .&. 0xF0- br = b0' .&. 0x0F- in (bl .|. br) : fold' bs- fold' (b:bs) = b : fold' bs- fold' [] = []--_urlencode :: (String -> B.ByteString) -> W.Word8 -> [Parameter] -> B.ByteString-_urlencode ve s p | null p = B.empty- | otherwise = (B.init . foldr fold' B.empty . L.sort) p- where - fold' (k,Nothing) = B.append (B.concat [encodes k, B.singleton 0x3d, B.singleton s])- fold' (k,Just v) = B.append (B.concat [encodes k, B.singleton 0x3d, ve v, B.singleton s])--_path_comp :: String -> [String]-_path_comp p = (filter (not . null) . L.unfoldr unfold') p ++ trailing'- where- unfold' p1 = case (break (=='/') p1)- of ([],[]) -> Nothing- (l,r) -> Just (l,drop 1 r)- - trailing' | last p=='/' = [[]]- | otherwise = []
− src/main/haskell/Network/Protocol/OAuth/Signature.hs
@@ -1,113 +0,0 @@--- Copyright (c) 2009, Diego Souza--- 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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.---- | Implements PLAINTEXT and HMAC-SHA1 signatures of oauth spec <http://oauth.net/core/1.0a#signing_process>-module Network.Protocol.OAuth.Signature (Method(..),Signer(sign)) where--import qualified Network.Protocol.OAuth.Request as R-import qualified Data.Digest.Pure.SHA as S-import qualified Data.Char as C-import qualified Data.ByteString.Lazy.Char8 as B1-import qualified Codec.Binary.Base64.String as B2-import qualified Codec.Crypto.RSA as R1---- | The signature method which will be used to sign requests.-data Method = - {-| The 'PLAINTEXT' /consumer_key/ /token_secret/ method does not provide- any security protection and SHOULD only be used over a secure channel- such as /HTTPS/. It does not use the Signature Base String.- -}- PLAINTEXT String (Maybe String)- {-| The 'HMAC_SHA1' /consumer_key/ /token_secret/ signature method uses the- /HMAC-SHA1/ signature algorithm as defined in- <http://tools.ietf.org/html/rfc2104> where the Signature Base String is- the text and the key is the concatenated values (each first encoded per- Parameter Encoding) of the Consumer Secret and Token Secret, separated- by an /&/ character (ASCII code 38) even if empty.- -}- | HMAC_SHA1 String (Maybe String) - {-| The 'RSA_SHA1' /rsa_privkey/ signature method uses the- RSASSA-PKCS1-v1_5 signature algorithm as defined in [RFC3447] section- 8.2 (more simply known as PKCS#1), using SHA-1 as the hash function for- EMSA-PKCS1-v1_5. It is assumed that the Consumer has provided its RSA- public key in a verified way to the Service Provider.- -}- | RSA_SHA1 R1.PrivateKey---- | Functions to sign requests according oauth spec.-class Signer a where- {-| For a given request, this function is able sign it using the method- specified. The full description of this process is described in depth- at <http://oauth.net/core/1.0a#signing_process>.- -}- sign :: a -- ^ The signature method to use- -> R.Request - -> String -- ^ The signature--instance Signer Method where- sign (PLAINTEXT k (Just s)) _ = k ++ "&" ++ s- sign (PLAINTEXT k Nothing) _ = k ++ "&"-- sign (HMAC_SHA1 k Nothing) r = let secret = B1.concat [R.encodes k, _froms "&"]- in (B2.encode . B1.unpack . S.bytestringDigest . S.hmacSha1 secret . _basestr) r- sign (HMAC_SHA1 k (Just s)) r = let secret = B1.concat [R.encodes k, _froms "&", R.encodes s]- in (B2.encode . B1.unpack . S.bytestringDigest . S.hmacSha1 secret . _basestr) r-- sign (RSA_SHA1 k) r = (B2.encode . B1.unpack . R1.rsassa_pkcs1_v1_5_sign R1.ha_SHA1 k . _basestr) r--instance Show Method where- showsPrec _ (PLAINTEXT _ _) = showString "PLAINTEXT"-- showsPrec _ (HMAC_SHA1 _ _) = showString "HMAC-SHA1"-- showsPrec _ (RSA_SHA1 _) = showString "RSA-SHA1"--_basestr :: R.Request -> B1.ByteString-_basestr r = let endpoint' = (R.encodes . _endpoint) r- params' = (R.encodes . _params) r- method' = (R.encodes . show . R.method) r- in B1.concat [method', _froms "&", endpoint', _froms "&", params']--_endpoint :: R.Request -> String-_endpoint r | R.ssl r = ssl_endpoint'- | otherwise = endpoint'- where- host' = (map C.toLower . R.host) r-- port' = ((':':) . show . R.port) r-- ssl_endpoint' | R.port r == 443 = "https://" ++ host' ++ (R.path r)- | otherwise = "https://" ++ host' ++ port' ++ (R.path r)-- endpoint' | R.port r == 80 = "http://" ++ host' ++ (R.path r)- | otherwise = "http://" ++ host' ++ port' ++ (R.path r)--_params :: R.Request -> String-_params = B1.unpack . R.show_urlencoded . R.params--_froms :: String -> B1.ByteString-_froms = B1.pack -