diff --git a/hoauth.cabal b/hoauth.cabal --- a/hoauth.cabal +++ b/hoauth.cabal @@ -1,5 +1,5 @@ name: hoauth -version: 0.3.3 +version: 0.3.4 category: Network,Protocol,OAuth license: BSD3 license-file: LICENSE @@ -19,6 +19,7 @@ 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 @@ -28,7 +29,8 @@ , random>=1.0.0.2 , curl>=1.3.5 , mtl>=1.1.0.2 - , RSA>=1.0.5 + , RSA>=1.2.0.1 + , entropy>=0.2.1 exposed-modules: Network.OAuth.Http.Request , Network.OAuth.Http.Response , Network.OAuth.Http.HttpClient @@ -42,4 +44,4 @@ source-repository head type: git - location: git@github.com:dsouza/hoauth.git + location: git://github.com/dsouza/hoauth.git diff --git a/src/main/haskell/Network/OAuth/Consumer.hs b/src/main/haskell/Network/OAuth/Consumer.hs --- a/src/main/haskell/Network/OAuth/Consumer.hs +++ b/src/main/haskell/Network/OAuth/Consumer.hs @@ -88,7 +88,7 @@ import Control.Monad import Control.Monad.Trans import System.IO -import System.Random (randomRIO) +import System.Entropy (getEntropy) import System.Locale (defaultTimeLocale) import Data.Time (getCurrentTime,formatTime) import Data.Char (chr,ord) @@ -97,12 +97,14 @@ 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 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,Eq) + deriving (Show) -- | Random string that is unique amongst requests. Refer to for more information. newtype Nonce = Nonce { unNonce :: String } @@ -202,9 +204,13 @@ ] 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. @@ -368,9 +374,7 @@ enquote = intercalate "," . map (\(k,v) -> encode k ++"=\""++ encode v ++"\"") _nonce :: (MonadIO m) => m Nonce -_nonce = do { rand <- liftIO (randomRIO (0,maxBound::Int)) - ; return (Nonce $ show rand) - } +_nonce = liftIO $ liftM (Nonce . B64.encode . BS.unpack) (getEntropy 32) _timestamp :: (MonadIO m) => m Timestamp _timestamp = do { clock <- liftIO getCurrentTime diff --git a/src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs b/src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs --- a/src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs +++ b/src/main/haskell/Network/OAuth/Http/CurlHttpClient.hs @@ -61,24 +61,37 @@ curlMethod = case (method req) of GET -> [ CurlHttpGet True ] HEAD -> [ CurlNoBody True,CurlCustomRequest "HEAD" ] - other -> if (B.null.reqPayload $ req) + 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 [] - else [ CurlPostFields [map (chr.fromIntegral).B.unpack.reqPayload $ req] ] - + 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 $ ("Content-Length: " ++ (show.B.length.reqPayload $ req)) - : headers - ] + in [CurlHttpHeaders headers] opts = [ CurlURL (showURL req) , CurlHttpVersion httpVersion , CurlHeader False - , CurlSSLVerifyHost 1 - , CurlSSLVerifyPeer False + , CurlSSLVerifyHost 2 + , CurlSSLVerifyPeer True , CurlTimeout 30 ] ++ curlHeaders ++ curlMethod diff --git a/src/main/haskell/Network/OAuth/Http/Request.hs b/src/main/haskell/Network/OAuth/Http/Request.hs --- a/src/main/haskell/Network/OAuth/Http/Request.hs +++ b/src/main/haskell/Network/OAuth/Http/Request.hs @@ -33,6 +33,10 @@ , FieldList() , Version(..) , Method(..) + , FormDataPart(..) + , Content(..) + -- * conversion of [FormDataPart] to curl's [HttpPost] + , convertMultipart -- * FieldList related functions , fromList , singleton @@ -58,6 +62,8 @@ ) 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) @@ -65,6 +71,7 @@ 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 @@ -85,18 +92,56 @@ 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 (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 @@ -154,6 +199,7 @@ , pathComps = [] , qString = fromList [] , reqPayload = B.empty + , multipartPayload = [] } -- | Parse a query string. @@ -175,6 +221,7 @@ , pathComps = [] , qString = fromList [] , reqPayload = B.empty + , multipartPayload = [] } -- | Creates a FieldList type from a list.