diff --git a/hoauth.cabal b/hoauth.cabal --- a/hoauth.cabal +++ b/hoauth.cabal @@ -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 +maintainer: Diego Souza 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: + More on OAuth protocol info at: 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 diff --git a/src/main/haskell/Network/OAuth/Consumer.hs b/src/main/haskell/Network/OAuth/Consumer.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Network/OAuth/Consumer.hs @@ -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 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 . +-- +-- 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 for more information. +type Nonce = String + +-- | Unix timestamp (seconds since epoch). Refer to for more information. +type Timestamp = String + +-- | The optional authentication realm. Refer to 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 + 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 diff --git a/src/main/haskell/Network/OAuth/Http/HttpClient.hs b/src/main/haskell/Network/OAuth/Http/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Network/OAuth/Http/HttpClient.hs @@ -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 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 diff --git a/src/main/haskell/Network/OAuth/Http/PercentEncoding.hs b/src/main/haskell/Network/OAuth/Http/PercentEncoding.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Network/OAuth/Http/PercentEncoding.hs @@ -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 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 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 diff --git a/src/main/haskell/Network/OAuth/Http/Request.hs b/src/main/haskell/Network/OAuth/Http/Request.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Network/OAuth/Http/Request.hs @@ -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 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 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 diff --git a/src/main/haskell/Network/OAuth/Http/Response.hs b/src/main/haskell/Network/OAuth/Http/Response.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Network/OAuth/Http/Response.hs @@ -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 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 diff --git a/src/main/haskell/Network/OAuth/Http/Util.hs b/src/main/haskell/Network/OAuth/Http/Util.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Network/OAuth/Http/Util.hs @@ -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 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 diff --git a/src/main/haskell/Network/Protocol/OAuth/Consumer.hs b/src/main/haskell/Network/Protocol/OAuth/Consumer.hs deleted file mode 100644 --- a/src/main/haskell/Network/Protocol/OAuth/Consumer.hs +++ /dev/null @@ -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 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 . --- --- Refer to 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) - diff --git a/src/main/haskell/Network/Protocol/OAuth/Request.hs b/src/main/haskell/Network/Protocol/OAuth/Request.hs deleted file mode 100644 --- a/src/main/haskell/Network/Protocol/OAuth/Request.hs +++ /dev/null @@ -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 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 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 = [] diff --git a/src/main/haskell/Network/Protocol/OAuth/Signature.hs b/src/main/haskell/Network/Protocol/OAuth/Signature.hs deleted file mode 100644 --- a/src/main/haskell/Network/Protocol/OAuth/Signature.hs +++ /dev/null @@ -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 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 -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 - 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 . - -} - 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 -