hoauth 0.2.5 → 0.3.0

raw patch · 8 files changed

+547/−388 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hoauth.cabal +9/−8
• src/main/haskell/Network/OAuth/Consumer.hs +286/−182
• src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs +87/−0
• src/main/haskell/Network/OAuth/Http/HttpClient.hs +10/−58
• src/main/haskell/Network/OAuth/Http/PercentEncoding.hs +10/−9
• src/main/haskell/Network/OAuth/Http/Request.hs +133/−119
• src/main/haskell/Network/OAuth/Http/Response.hs +8/−8
• src/main/haskell/Network/OAuth/Http/Util.hs +4/−4

@@ -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

@@ -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 <http://oauth.net/core/1.0/#nonce> for more information.-type Nonce = String+newtype Nonce = Nonce { unNonce :: String }+              deriving (Eq)  -- | Unix timestamp (seconds since epoch). Refer to <http://oauth.net/core/1.0/#nonce> for more information.-type Timestamp = String+newtype Timestamp = Timestamp { unTimestamp :: String }+                  deriving (Eq,Ord)  -- | The optional authentication realm. Refer to <http://oauth.net/core/1.0/#auth_header_authorization> 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-        <http://tools.ietf.org/html/rfc2104> where the Signature Base String is-        the text and the key is the concatenated values (each first encoded per-        Parameter Encoding) of the Consumer Secret and Token Secret, separated-        by an /&/ character (ASCII code 38) even if empty.-    -}+  {-| The 'PLAINTEXT' /consumer_key/ /token_secret/ method does not provide+      any security protection and SHOULD only be used over a secure channel+      such as /HTTPS/. It does not use the Signature Base String.+  -}+  PLAINTEXT+  {-| The 'HMAC_SHA1' /consumer_key/ /token_secret/ signature method uses the+      /HMAC-SHA1/ signature algorithm as defined in+      <http://tools.ietf.org/html/rfc2104> where the Signature Base String is+      the text and the key is the concatenated values (each first encoded per+      Parameter Encoding) of the Consumer Secret and Token Secret, separated+      by an /&/ character (ASCII code 38) even if empty.+  -}   | HMACSHA1+  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

@@ -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 <ORGANIZATION> nor the names of its contributors+--     may be used to endorse or promote products derived from this software+--     without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-- | A type class that is able to perform HTTP requests.+module Network.OAuth.Http.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)

@@ -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

@@ -26,9 +26,10 @@  -- | Percent encoding <http://tools.ietf.org/html/rfc3986#page-12> functions, -- with the exception that all encoding/decoding is in UTF-8.-module Network.OAuth.Http.PercentEncoding (PercentEncoding(..)-                                          ,decodeWithDefault-                                          ) where+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

@@ -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 <findWithDefault> but the match is case-insenstiive. ifindWithDefault :: (String,String) -> FieldList -> String-ifindWithDefault (key,def) fields | null values = def-                                  | otherwise   = head values-  where values = find (\k -> lower k == lower key) fields-        lower  = map toLower+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

@@ -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

@@ -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