hoauth-0.3.5/0000755000000000000000000000000012017543077011203 5ustar0000000000000000hoauth-0.3.5/Setup.hs0000644000000000000000000000314612017543077012643 0ustar0000000000000000-- 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. import Distribution.Simple main :: IO () main = defaultMain hoauth-0.3.5/hoauth.cabal0000644000000000000000000000306612017543077013464 0ustar0000000000000000name: hoauth version: 0.3.5 category: Network,Protocol,OAuth license: BSD3 license-file: LICENSE author: Diego Souza maintainer: Diego Souza stability: experimental build-type: Simple cabal-version: >= 1.6 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 on OAuth protocol info at: library build-depends: base<5 , bytestring>=0.9.1.5 , crypto-pubkey-types>=0.1.1 , binary>=0.5.0.2 , SHA>=1.4.1.1 , dataenc>=0.13.0.2 , utf8-string>=0.3.4 , time>=1.1.4 , old-locale>=1.0.0.2 , random>=1.0.0.2 , curl>=1.3.5 , mtl>=1.1.0.2 , RSA>=1.2.0.1 , entropy>=0.2.1 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 source-repository head type: git location: git://github.com/dsouza/hoauth.git hoauth-0.3.5/LICENSE0000644000000000000000000000273512017543077012217 0ustar0000000000000000Copyright (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. hoauth-0.3.5/src/0000755000000000000000000000000012017543077011772 5ustar0000000000000000hoauth-0.3.5/src/main/0000755000000000000000000000000012017543077012716 5ustar0000000000000000hoauth-0.3.5/src/main/haskell/0000755000000000000000000000000012017543077014341 5ustar0000000000000000hoauth-0.3.5/src/main/haskell/Network/0000755000000000000000000000000012017543077015772 5ustar0000000000000000hoauth-0.3.5/src/main/haskell/Network/OAuth/0000755000000000000000000000000012017543077017012 5ustar0000000000000000hoauth-0.3.5/src/main/haskell/Network/OAuth/Consumer.hs0000644000000000000000000005206312017543077021147 0ustar0000000000000000-- 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","ERROR") . oauthParams -- > app = Application "consumerKey" "consumerSec" OOB -- > response = runOAuthM (fromApplication app) $ do { 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 , oauthRequest , packRq , signRq , signRq2 , 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 import Control.Monad.Trans import System.IO import System.Entropy (getEntropy) import System.Locale (defaultTimeLocale) import Data.Time (getCurrentTime,formatTime) import Data.Char (chr,ord) import Data.List (intercalate,sort) 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 as BS import qualified Data.ByteString.Lazy as B import qualified Codec.Crypto.RSA as R import qualified Crypto.Types.PubKey.RSA as R -- | A request that is ready to be performed, i.e., that contains authorization headers. newtype OAuthRequest = OAuthRequest { unpackRq :: Request } deriving (Show) -- | Random string that is unique amongst requests. Refer to for more information. newtype Nonce = Nonce { unNonce :: String } deriving (Eq) -- | Unix timestamp (seconds since epoch). Refer to for more information. newtype Timestamp = Timestamp { unTimestamp :: String } deriving (Eq,Ord) -- | The optional authentication realm. Refer to for more information. newtype Realm = Realm { unRealm :: String } deriving (Eq) -- | 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 (Eq) -- | The OAuth Token. data Token = {-| This token is used to perform 2 legged OAuth requests. -} 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 } {-| 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 "RSA-SHA1" signature method uses the RSASSA-PKCS1-v1_5 signature algorithm as defined in [RFC3447], Section 8.2 (also known as PKCS#1), using SHA-1 as the hash function for EMSA-PKCS1-v1_5. To use this method, the client MUST have established client credentials with the server that included its RSA public key (in a manner that is beyond the scope of this specification). -} | RSASHA1 R.PrivateKey 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). signature :: SigMethod -> Token -> Request -> String signature m token req = case m of PLAINTEXT -> key HMACSHA1 -> b64encode $ S.bytestringDigest (S.hmacSha1 (bsencode key) (bsencode text)) RSASHA1 k -> b64encode $ R.rsassa_pkcs1_v1_5_sign R.ha_SHA1 k (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") -- e.g., in the case of most Twitter API calls then (qString req) `unionAll` (parseQString . map (chr.fromIntegral) . B.unpack . reqPayload $ req) -- e.g., in the case of a "multipart/form-data" image upload, however, the payload isn't signed 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 -> OAuthMonadT m () ignite = putToken . fromApplication -- | Creates a TwoLegg token from an application fromApplication :: Application -> Token fromApplication app = TwoLegg app 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 -- | Executes an oauth request which is intended to upgrade/refresh the current -- token. 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 :: (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 ++"]" } -- | 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. packRq :: Request -> OAuthRequest packRq = OAuthRequest -- | Complete the request with authorization headers. signRq :: (MonadIO m) => Token -> SigMethod -> Maybe Realm -> Request -> m OAuthRequest 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 -> 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 _ 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) -> 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 -- 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 errorMessage 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 | twoLegged token = [ "oauth_token" , "oauth_token_secret" , "oauth_callback_confirmed" ] | 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", unNonce nonce) , ("oauth_timestamp", unTimestamp time) , ("oauth_signature_method", showMethod m) , ("oauth_version", "1.0") ] ++ extra showMethod HMACSHA1 = "HMAC-SHA1" showMethod (RSASHA1 _) = "RSA-SHA1" showMethod PLAINTEXT = "PLAINTEXT" oauthPrefix = case realm of Nothing -> "OAuth " 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) ] 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 = liftIO $ liftM (Nonce . B64.encode . BS.unpack) (getEntropy 32) _timestamp :: (MonadIO m) => m Timestamp _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 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 _ -> 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) } 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#get: parse error" } hoauth-0.3.5/src/main/haskell/Network/OAuth/Http/0000755000000000000000000000000012017543077017731 5ustar0000000000000000hoauth-0.3.5/src/main/haskell/Network/OAuth/Http/PercentEncoding.hs0000644000000000000000000000772712017543077023351 0ustar0000000000000000-- 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.List (unfoldr) import qualified Codec.Binary.UTF8.String as U import Data.Char (intToDigit,digitToInt,toUpper,ord,chr) import Data.Bits import Data.Word (Word8) 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 = concatMap encode (U.encode [c]) 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) instance PercentEncoding Word8 where encode b | b `elem` whitelist = [chr.fromIntegral $ b] | otherwise = '%' : map (toUpper.intToDigit.fromIntegral) [shiftR (b .&. 0xF0) 4,b .&. 0x0F] where whitelist = [97..122] ++ [65..90] ++ [48..57] ++ [45,46,95,126] decode [] = Nothing decode (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 Just (byte,bs') _ -> Just (fromIntegral (ord b),bs) instance (PercentEncoding a) => PercentEncoding [a] where encode = concatMap encode decode = pack . unfoldr decode where pack xs = Just (xs,"") -- | 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 hoauth-0.3.5/src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs0000644000000000000000000001272512017543077023200 0ustar0000000000000000{-# 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 import qualified Data.ByteString.Lazy.UTF8 as U data CurlClient = CurlClient | OptionsCurlClient [CurlOption] instance HttpClient CurlClient where runClient client 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) && 0 == length (multipartPayload req)) then [ CurlHttpGet True,CurlCustomRequest (show other) ] else [ CurlPost True,CurlCustomRequest (show other) ] curlPostData = if B.null . reqPayload $ req then case multipartPayload req of [] -> [] -- i.e., no payload at all parts -> [CurlHttpPost (convertMultipart parts)] -- i.e., "multipart/form-data" -- content with a boundary and MIME stuff -- see libcurl for HttpPost, Content else case multipartPayload req of [] -> let tostr = map (chr.fromIntegral).B.unpack field = reqPayload req in [CurlPostFields [tostr field]] -- i.e., "application/x-www-form-urlencoded" -- strings with field sep '&' -- although we're only giving libcurl a single field _ -> error "with both CurlPostFields and CurlHttpPost, I'm not sure what libcurl would do..." curlHeaders = let headers = (map (\(k,v) -> k++": "++v).toList.reqHeaders $ req) in [CurlHttpHeaders headers] opts = [ CurlURL (showURL req) , CurlHttpVersion httpVersion , CurlHeader False , CurlSSLVerifyHost 2 , CurlSSLVerifyPeer True , CurlTimeout 30 ] ++ curlHeaders ++ curlMethod ++ curlPostData ++ clientOptions clientOptions = case client of CurlClient -> [] OptionsCurlClient o -> o packedBody rsp = U.fromString . respBody $ rsp fromResponse rsp = RspHttp (respStatus rsp) (respStatusLine rsp) (fromList.respHeaders $ rsp) (packedBody rsp) hoauth-0.3.5/src/main/haskell/Network/OAuth/Http/HttpClient.hs0000644000000000000000000000405712017543077022351 0ustar0000000000000000-- 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. -- | 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.OAuth.Http.Request import Network.OAuth.Http.Response import Control.Monad.Trans 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 hoauth-0.3.5/src/main/haskell/Network/OAuth/Http/Util.hs0000644000000000000000000000347312017543077021211 0ustar0000000000000000-- 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 []] hoauth-0.3.5/src/main/haskell/Network/OAuth/Http/Request.hs0000644000000000000000000003524612017543077021727 0ustar0000000000000000{-# 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(..) , FormDataPart(..) , Content(..) -- * conversion of [FormDataPart] to curl's [HttpPost] , convertMultipart -- * 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 qualified Network.Curl.Post as Curl (HttpPost(..), Content(..)) import qualified Network.Curl.Types as Curl (Long) 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 import Foreign.C.String (CString) -- | 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 (the first/only string part) , multipartPayload :: [FormDataPart] -- ^ The message body (i.e., for multipart/form-data) } deriving (Eq,Show) -- one part of a multipart/form-data POST request data FormDataPart = FormDataPart { postName :: String , contentType :: Maybe String , content :: Content , extraHeaders :: [String] -- , extraEntries :: [FormDataPart] -- commented out in Curl's Post.hs , showName :: Maybe String } deriving (Eq, Show) -- data for one part -- as either a String or a FilePath (for Curl to open and include) data Content = ContentFile FilePath | ContentBuffer CString Curl.Long | ContentString String deriving (Eq, Show) -- convert one Part to Curl's HttpPost convertMultipart :: [FormDataPart] -> [Curl.HttpPost] convertMultipart parts = map convertPart parts where convertPart :: FormDataPart -> Curl.HttpPost convertPart part = Curl.HttpPost { Curl.postName = postName part , Curl.contentType = contentType part , Curl.content = convertCont (content part) , Curl.extraHeaders = extraHeaders part , Curl.showName = showName part } convertCont :: Content -> Curl.Content convertCont (ContentFile z) = Curl.ContentFile z convertCont (ContentString y) = Curl.ContentString y convertCont (ContentBuffer w x) = Curl.ContentBuffer w x -- | 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 , multipartPayload = [] } -- | 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 , multipartPayload = [] } -- | 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 = 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 = do { (tape,req) <- get ; let (value,tape') = break (`elem` ":/") tape ; put (tape',liftM (\r -> r {host = value}) req) } _parsePort :: State (String,Maybe Request) () _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 = 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 = 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) = 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 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 hoauth-0.3.5/src/main/haskell/Network/OAuth/Http/Response.hs0000644000000000000000000000477512017543077022100 0ustar0000000000000000-- 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) , 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) -- contentType :: Response -> (String,FieldList) -- contentType = let string = findWithDefault ("content-type","text/html") . rspHeaders -- (type_,params) = break (==';') string -- in (trim type_,trim charset)