diff --git a/hoauth.cabal b/hoauth.cabal --- a/hoauth.cabal +++ b/hoauth.cabal @@ -1,5 +1,5 @@ name: hoauth -version: 0.2.5 +version: 0.3.0 category: Network,Protocol,OAuth license: BSD3 license-file: LICENSE @@ -28,15 +28,16 @@ ,random>=1.0.0.2 ,curl>=1.3.5 ,mtl>=1.1.0.2 - 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 + exposed-modules: Network.OAuth.Http.Request + , Network.OAuth.Http.Response + , Network.OAuth.Http.HttpClient + , Network.OAuth.Http.CurlHttpClient + , Network.OAuth.Http.PercentEncoding + , Network.OAuth.Http.Util + , Network.OAuth.Consumer hs-source-dirs: src/main/haskell - ghc-options: -W -Wall -fwarn-tabs + ghc-options: -W -Wall source-repository head type: git diff --git a/src/main/haskell/Network/OAuth/Consumer.hs b/src/main/haskell/Network/OAuth/Consumer.hs --- a/src/main/haskell/Network/OAuth/Consumer.hs +++ b/src/main/haskell/Network/OAuth/Consumer.hs @@ -35,125 +35,145 @@ -- -- 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(..) - ,OAuthCallback(..) - ,SigMethod(..) - ,Realm - ,Nonce - ,Timestamp - ,OAuthMonad - -- * OAuthMonad related functions - ,runOAuth - ,oauthRequest - ,completeRequest - ,serviceRequest - ,cliAskAuthorization - ,ignite - ,getToken - ,putToken - -- * Token related functions - ,twoLegged - ,threeLegged - ,signature - ,injectOAuthVerifier - ,fromApplication - ,fromResponse - ,authorization - ) where +-- > 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","ERROR") . oauthParams +-- > app = Application "consumerKey" "consumerSec" OOB +-- > response = runOAuthM_ $ do { ignite app +-- > ; signRq2 PLAINTEXT Nothing reqUrl >>= oauthRequest CurlHttpClient +-- > ; cliAskAuthorization authUrl +-- > ; signRq2 PLAINTEXT Nothing accUrl >>= oauthRequest CurlHttpClient +-- > ; signRq2 HMACSHA1 (Just $ Realm "realm") srvUrl >>= serviceRequest CurlHttpClient +-- > } +-- +module Network.OAuth.Consumer + ( -- * Types + OAuthMonadT() + , OAuthRequest(unpackRq) + , Token(..) + , Application(..) + , OAuthCallback(..) + , SigMethod(..) + , Realm(..) + , Nonce(..) + , Timestamp(..) + -- * OAuthMonadT related functions + , runOAuth + , runOAuthM + , runOAuthM_ + , oauthRequest + , packRq + , signRq + , signRq2 + , serviceRequest + , cliAskAuthorization + , ignite + , getToken + , putToken + + -- * Token related functions + , twoLegged + , threeLegged + , notoken + , 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 Control.Monad +import Control.Monad.Trans +import System.IO import System.Random (randomRIO) -import Data.Time (getCurrentTime,formatTime) import System.Locale (defaultTimeLocale) +import Data.Time (getCurrentTime,formatTime) 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.Binary as Bi import qualified Data.Digest.Pure.SHA as S import qualified Codec.Binary.Base64 as B64 import qualified Data.ByteString.Lazy as B +-- | A request that is ready to be performed, i.e., that contains authorization headers. +newtype OAuthRequest = OAuthRequest { unpackRq :: Request } + deriving (Show,Eq) + -- | Random string that is unique amongst requests. Refer to for more information. -type Nonce = String +newtype Nonce = Nonce { unNonce :: String } + deriving (Eq) -- | Unix timestamp (seconds since epoch). Refer to for more information. -type Timestamp = String +newtype Timestamp = Timestamp { unTimestamp :: String } + deriving (Eq,Ord) -- | The optional authentication realm. Refer to for more information. -type Realm = String +newtype Realm = Realm { unRealm :: String } + deriving (Eq) -- | Callback used in oauth authorization -data OAuthCallback = URL String - | OOB - deriving (Eq) +data OAuthCallback = URL String + | OOB + deriving (Eq) -- | Identifies the application. data Application = Application { consKey :: String , consSec :: String , callback :: OAuthCallback } - deriving (Eq) + deriving (Eq) -- | The OAuth Token. data Token = {-| This token is used to perform 2 legged OAuth requests. -} - TwoLegg {application :: Application - ,oauthParams :: FieldList - } + TwoLegg { application :: Application + , oauthParams :: FieldList + } {-| The service provider has granted you the request token but the user has not yet authorized your application. You need to exchange this token by a proper AccessToken, but this may only happen after user has granted you permission to do so. -} - | ReqToken {application :: Application - ,oauthParams :: FieldList + | 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 + | AccessToken { application :: Application + , oauthParams :: FieldList } + {-| Use this when there is no oauth token present. The request goes unauthenticated. + -} + | NoToken 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. - -} + {-| 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 + deriving (Eq) --- | The OAuth monad. -type OAuthMonad m a = StateT Token m a +data OAuthMonadT m a = OAuthMonadT (Token -> m (Either String (Token,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). @@ -168,13 +188,13 @@ ++"&"++ 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 + 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") @@ -193,65 +213,99 @@ threeLegged (AccessToken _ _) = True threeLegged _ = False +-- | Tests whether or not the current token is NoToken. +notoken :: Token -> Bool +notoken NoToken = True +notoken _ = False + -- | Transforms an application into a token. -ignite :: (MonadIO m) => Application -> OAuthMonad m () -ignite = put . fromApplication +ignite :: (MonadIO m) => Application -> OAuthMonadT m () +ignite = putToken . fromApplication --- | Transforms an application into a token +-- | Creates a TwoLegg token from an application 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) +-- | Execute the oauth monad using a given error handler +runOAuth :: (Monad m) => (String -> m a) -> Token -> OAuthMonadT m a -> m a +runOAuth h t (OAuthMonadT f) = do { v <- f t + ; case v + of Right (_,a) -> return a + Left err -> h err + } +-- | Execute the oauth monad and returns the value it produced using +-- `fail` as the error handler. +runOAuthM :: (Monad m) => Token -> OAuthMonadT m a -> m a +runOAuthM = runOAuth fail + +-- | Invokes runOAuthM with NoToken using fail as the error handler. +runOAuthM_ :: (Monad m) => OAuthMonadT m a -> m a +runOAuthM_ = runOAuthM NoToken + -- | 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 Token -oauthRequest sigm realm req = do response <- serviceRequest sigm realm req - token <- get - case (fromResponse response token) - of (Right token') -> do put token' - return token' - (Left err) -> fail err - --- | Simply complete the request with the required information to perform the oauth request. -completeRequest :: (MonadIO m) => SigMethod -> Token -> Maybe Realm -> Request -> m Request -completeRequest sigm token realm req = do nonce <- _nonce - timestamp <- _timestamp - let authValue = authorization sigm realm nonce timestamp token req - return (req {reqHeaders = insert ("Authorization",authValue) (reqHeaders req)}) +oauthRequest :: (HttpClient c, MonadIO m) => c -> OAuthRequest -> OAuthMonadT m Token +oauthRequest c req = do { response <- serviceRequest c req + ; token <- getToken + ; case (fromResponse response token) + of Right token' -> do { putToken token' + ; return token' + } + Left err -> fail err + } -- | Performs a signed request with the available token. -serviceRequest :: (MonadIO m,HttpClient m) => SigMethod -> Maybe Realm -> Request -> OAuthMonad m Response -serviceRequest sigm realm req0 = do token <- get - req <- completeRequest sigm token realm req0 - lift (request req) +serviceRequest :: (HttpClient c,MonadIO m) => c -> OAuthRequest -> OAuthMonadT m Response +serviceRequest c req = do { result <- lift $ runClient c (unpackRq req) + ; case (result) + of Right rsp -> return rsp + Left err -> fail $ "Failure performing the request. [reason=" ++ err ++"]" + } --- | Extracts the token from the OAuthMonad. -getToken :: (Monad m) => OAuthMonad m Token -getToken = get +-- | Complete the request with authorization headers. +signRq2 :: (MonadIO m) => SigMethod -> Maybe Realm -> Request -> OAuthMonadT m OAuthRequest +signRq2 sigm realm req = getToken >>= \t -> lift $ signRq t sigm realm req +-- | Simply create the OAuthRequest but adds no Authorization header. This is the same as using signRq with NoToken. +packRq :: Request -> OAuthRequest +packRq = OAuthRequest + +-- | Complete the request with authorization headers. +signRq :: (MonadIO m) => Token -> SigMethod -> Maybe Realm -> Request -> m OAuthRequest +signRq NoToken _ _ req = return (packRq req) +signRq token sigm realm req0 = do { nonce <- _nonce + ; timestamp <- _timestamp + ; let authValue = authorization sigm realm nonce timestamp token req0 + req = req0 { reqHeaders = insert ("Authorization", authValue) (reqHeaders req0) } + ; return (OAuthRequest req) + } + +-- | Extracts the token from the OAuthMonadT. +getToken :: (Monad m) => OAuthMonadT m Token +getToken = OAuthMonadT $ \t -> return $ Right (t,t) + -- | Alias to the put function. -putToken :: (Monad m) => Token -> OAuthMonad m () -putToken = put +putToken :: (Monad m) => Token -> OAuthMonadT m () +putToken t = OAuthMonadT $ const (return $ Right (t,())) -- | 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 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) +cliAskAuthorization :: (MonadIO m) => (Token -> String) -> OAuthMonadT m () +cliAskAuthorization getUrl = do { token <- getToken + ; answer <- liftIO $ do { hSetBuffering stdout NoBuffering + ; putStrLn ("open " ++ (getUrl token)) + ; putStr "oauth_verifier: " + ; getLine + } + ; putToken (injectOAuthVerifier answer token) + } -- | Receives a response possibly from a service provider and updates the -- token. As a matter effect, assumes the content-type is @@ -259,10 +313,11 @@ -- 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) + 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) + NoToken -> Right $ NoToken + | otherwise = Left errorMessage where payload = parseQString . map (chr.fromIntegral) . B.unpack . rspPayload $ rsp validRsp = statusOk && paramsOk @@ -271,52 +326,89 @@ 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" - ] + requiredKeys + | twoLegged token = [ "oauth_token" + , "oauth_token_secret" + , "oauth_callback_confirmed" + ] + | notoken token = [] + | otherwise = [ "oauth_token" + , "oauth_token_secret" + ] + errorMessage + | not statusOk = "Bad status code. [response=" ++ debug ++ "]" + | not paramsOk = "Missing at least one required oauth parameter [expecting="++ show requiredKeys ++", response="++ debug ++"]" + | otherwise = error "Consumer#fromResponse: not an error!" + where debug = concat [ "status: " ++ show (status rsp) + , ", reason: " ++ reason rsp + ] + -- | 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") + where oauthFields = [ ("oauth_consumer_key", consKey.application $ token) + , ("oauth_nonce", unNonce nonce) + , ("oauth_timestamp", unTimestamp time) + , ("oauth_signature_method", show m) + , ("oauth_version", "1.0") ] ++ extra oauthPrefix = case realm of Nothing -> "OAuth " - Just v -> "OAuth realm=\""++encode v++"\"," + Just v -> "OAuth realm=\"" ++ encode (unRealm 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) - ] + 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) + ] + NoToken -> [] 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) +_nonce = do { rand <- liftIO (randomRIO (0,maxBound::Int)) + ; return (Nonce $ show rand) + } _timestamp :: (MonadIO m) => m Timestamp -_timestamp = do clock <- liftIO getCurrentTime - return (formatTime defaultTimeLocale "%s" clock) +_timestamp = do { clock <- liftIO getCurrentTime + ; return (Timestamp $ formatTime defaultTimeLocale "%s" clock) + } +instance (Monad m) => Monad (OAuthMonadT m) where + return a = OAuthMonadT $ \t -> return $ Right (t,a) + fail err = OAuthMonadT $ \_ -> return $ Left err + + (OAuthMonadT ma) >>= f = OAuthMonadT $ \t0 -> ma t0 >>= either left right + where left = return . Left + right (t1,a) = let OAuthMonadT mb = f a + in mb t1 + +instance MonadTrans OAuthMonadT where + lift ma = OAuthMonadT $ \t -> do { a <- ma + ; return $ Right (t,a) + } + +instance (MonadIO m) => MonadIO (OAuthMonadT m) where + liftIO ma = OAuthMonadT $ \t -> do { a <- liftIO ma + ; return $ Right (t,a) + } + +instance (Monad m,Functor m) => Functor (OAuthMonadT m) where + fmap f (OAuthMonadT ma) = OAuthMonadT $ \t0 -> ma t0 >>= either left right + where left = return . Left + right (t1,a) = return (Right (t1, f a)) + instance Show SigMethod where showsPrec _ PLAINTEXT = showString "PLAINTEXT" - showsPrec _ HMACSHA1 = showString "HMAC-SHA1" + showsPrec _ HMACSHA1 = showString "HMAC-SHA1" instance Show OAuthCallback where showsPrec _ OOB = showString "oob" @@ -324,46 +416,58 @@ instance Bi.Binary OAuthCallback where put OOB = Bi.put (0 :: Word8) - put (URL url) = do Bi.put (1 :: Word8) - Bi.put url + 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 - _ -> fail "Consumer: parse error" + get = do { t <- Bi.get :: Bi.Get Word8 + ; case t + of 0 -> return OOB + 1 -> fmap URL Bi.get + _ -> fail "Consumer#get: parse error" + } instance Bi.Binary Application where - put app = do Bi.put (consKey app) - Bi.put (consSec app) - Bi.put (callback app) + 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_) + 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) - _ -> fail "Consumer: parse error" + 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 + } + put NoToken = Bi.put (3 :: Word8) + 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) + } + 3 -> return NoToken + _ -> fail "Consumer#get: parse error" + } --- vim:sts=2:sw=2:ts=2:et diff --git a/src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs b/src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs new file mode 100644 --- /dev/null +++ b/src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE FlexibleInstances #-} +-- 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.CurlHttpClient + ( CurlClient(..) + ) where + +import Network.Curl +import Network.OAuth.Http.HttpClient +import Network.OAuth.Http.Request +import Network.OAuth.Http.Response +import Control.Monad.Trans +import Data.Char (chr,ord) +import qualified Data.ByteString.Lazy as B + +data CurlClient = CurlClient + +instance HttpClient CurlClient where + runClient _ req = liftIO $ withCurlDo $ do { c <- initialize + ; setopts c opts + ; rsp <- perform_with_response_ c + ; case (respCurlCode rsp) + of errno + | errno `elem` successCodes -> return $ Right (fromResponse rsp) + | otherwise -> return $ Left (show errno) + } + where httpVersion = case (version req) + of Http10 -> HttpVersion10 + Http11 -> HttpVersion11 + + successCodes = [ CurlOK + , CurlHttpReturnedError + ] + + curlMethod = case (method req) + of GET -> [ CurlHttpGet 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 $ ("Content-Length: " ++ (show.B.length.reqPayload $ req)) + : headers + ] + + opts = [ CurlURL (showURL req) + , CurlHttpVersion httpVersion + , CurlHeader False + , CurlSSLVerifyHost 1 + , CurlSSLVerifyPeer False + , CurlTimeout 30 + ] ++ curlHeaders + ++ curlMethod + ++ curlPostData + + fromResponse rsp = RspHttp (respStatus rsp) (respStatusLine rsp) (fromList.respHeaders $ rsp) (B.pack.map (fromIntegral.ord).respBody $ rsp) diff --git a/src/main/haskell/Network/OAuth/Http/HttpClient.hs b/src/main/haskell/Network/OAuth/Http/HttpClient.hs --- a/src/main/haskell/Network/OAuth/Http/HttpClient.hs +++ b/src/main/haskell/Network/OAuth/Http/HttpClient.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- Copyright (c) 2009, Diego Souza -- All rights reserved. -- @@ -26,64 +24,18 @@ -- 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 +-- | Minimum definition of a user agent required to implement oauth +-- service calls. This should suffice for most applications. +module Network.OAuth.Http.HttpClient + ( HttpClient(..) + ) where -import Network.Curl -import Control.Monad.Fix import Network.OAuth.Http.Request import Network.OAuth.Http.Response import Control.Monad.Trans -import Data.Char (chr,ord) -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 - - -- | Unpacks the monad and returns the inner IO monad. - unpack :: m a -> IO a - --- | The libcurl backend -newtype CurlM a = CurlM { unCurlM :: IO a } - deriving (Monad,MonadIO,MonadFix,Functor) - -instance HttpClient CurlM where - unpack = unCurlM - - request req = CurlM $ withCurlDo $ do c <- initialize - setopts c opts - rsp <- perform_with_response_ c - return $ RspHttp (respStatus rsp) - (respStatusLine rsp) - (fromList.respHeaders $ rsp) - (B.pack.map (fromIntegral.ord).respBody $ rsp) - where httpVersion = case (version req) - of Http10 -> HttpVersion10 - Http11 -> HttpVersion11 - - curlMethod = case (method req) - of GET -> [CurlHttpGet 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 $ ("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 +class HttpClient c where + runClient :: (MonadIO m) => c -> Request -> m (Either String Response) + + runClient_ :: (MonadIO m) => c -> Request -> m Response + runClient_ c r = runClient c r >>= either fail return diff --git a/src/main/haskell/Network/OAuth/Http/PercentEncoding.hs b/src/main/haskell/Network/OAuth/Http/PercentEncoding.hs --- a/src/main/haskell/Network/OAuth/Http/PercentEncoding.hs +++ b/src/main/haskell/Network/OAuth/Http/PercentEncoding.hs @@ -26,9 +26,10 @@ -- | Percent encoding functions, -- with the exception that all encoding/decoding is in UTF-8. -module Network.OAuth.Http.PercentEncoding (PercentEncoding(..) - ,decodeWithDefault - ) where +module Network.OAuth.Http.PercentEncoding + ( PercentEncoding(..) + , decodeWithDefault + ) where import Data.List (unfoldr) import qualified Codec.Binary.UTF8.String as U @@ -49,11 +50,12 @@ decode [] = Nothing decode (x:xs) = case (fmap (U.decode.fst) (decode (x:xs))) - of Nothing -> Nothing - Just [] -> Nothing - Just (y:_) | x=='%' -> let sizeof = length (encode y) - 1 - in Just (y,drop sizeof xs) - | otherwise -> Just (y,xs) + of Nothing -> Nothing + Just [] -> Nothing + Just (y:_) + | x=='%' -> let sizeof = length (encode y) - 1 + in Just (y,drop sizeof xs) + | otherwise -> Just (y,xs) instance PercentEncoding Word8 where encode b | b `elem` whitelist = [chr.fromIntegral $ b] @@ -84,4 +86,3 @@ 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 --- a/src/main/haskell/Network/OAuth/Http/Request.hs +++ b/src/main/haskell/Network/OAuth/Http/Request.hs @@ -27,35 +27,35 @@ -- 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 +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 @@ -82,32 +82,34 @@ deriving (Eq) -- | Key-value list. -newtype FieldList = FieldList {unFieldList :: [(String,String)]} +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 +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" +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) +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 @@ -123,53 +125,56 @@ . zipWith ($) [showProtocol,const "://",showAuthority,showPath,showQString'] . repeat where showQString' :: Request -> String - showQString' req | null (unFieldList (qString req)) = "" - | otherwise = '?' : showQString req + 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 + 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) + 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 + 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. @@ -192,9 +197,10 @@ -- 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' _ [] = [] + 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 @@ -202,8 +208,9 @@ -- | 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 +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 @@ -225,60 +232,68 @@ -- 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 +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 +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) +_parseProtocol = do { (tape,req) <- get + ; 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) +_parseHost = do { (tape,req) <- get + ; let (value,tape') = break (`elem` ":/") tape + ; 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) +_parsePort = do { (tape,req) <- get + ; let (value,tape') = break (=='/') tape + ; 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) +_parsePath = do { (tape,req) <- get + ; let (value,tape') = break (=='?') tape + value' = "" : map (decodeWithDefault "") (splitBy (=='/') value) + ; 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) +_parseQString = do { (tape,req) <- get + ; let (value,tape') = break (=='#') tape + fields = fromList $ filter (/=("","")) (map parseField (splitBy (=='&') value)) + ; 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) +_parseSymbol (c,required) = do { (tape,req) <- get + ; 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 @@ -322,4 +337,3 @@ 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 --- a/src/main/haskell/Network/OAuth/Http/Response.hs +++ b/src/main/haskell/Network/OAuth/Http/Response.hs @@ -26,22 +26,22 @@ -- | 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 +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 +data Response = RspHttp { status :: Int -- ^ The status code (e.g. 200, 302) + , reason :: 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) + 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 --- a/src/main/haskell/Network/OAuth/Http/Util.hs +++ b/src/main/haskell/Network/OAuth/Http/Util.hs @@ -28,8 +28,8 @@ 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 []] + 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