haxr 3000.9.2.1 → 3000.9.3
raw patch · 3 files changed
+51/−46 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGES +5/−0
- Network/XmlRpc/Client.hs +45/−45
- haxr.cabal +1/−1
CHANGES view
@@ -1,3 +1,8 @@+* 3000.9.3 (18 May 2013)++ - Critical bug fix --- do not use 3000.9.2, it is extremely broken+ (hangs forever when trying to send a request).+ * 3000.9.2.1 (15 May 2013) - Allow HaXml-1.24
Network/XmlRpc/Client.hs view
@@ -35,22 +35,22 @@ Remote ) where -import qualified Network.XmlRpc.Base64 as Base64-import Network.XmlRpc.Internals+import qualified Network.XmlRpc.Base64 as Base64+import Network.XmlRpc.Internals -import Control.Exception (handleJust)-import Data.Char-import Data.Maybe-import Data.Word (Word8)-import Network.URI-import Network.Socket (withSocketsDo)+import Control.Exception (handleJust)+import Data.Char+import Data.Maybe+import Data.Word (Word8)+import Network.Socket (withSocketsDo)+import Network.URI -import Network.HTTP-import Network.Stream+import Network.HTTP+import Network.Stream +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, toChunks)-import qualified Data.ByteString.UTF8 as U-import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.UTF8 as U -- | Gets the return value from a method response. -- Throws an exception if the response was a fault.@@ -87,43 +87,43 @@ -- HTTP request. -- Throws an exception if the response was a fault. callWithHeaders :: String -- ^ URL for the XML-RPC server.- -> String -- ^ Method name.- -> [Header] -- ^ Extra headers to add to HTTP request.- -> [Value] -- ^ The arguments.- -> Err IO Value -- ^ The result+ -> String -- ^ Method name.+ -> [Header] -- ^ Extra headers to add to HTTP request.+ -> [Value] -- ^ The arguments.+ -> Err IO Value -- ^ The result callWithHeaders url method headers args = doCall url headers (MethodCall method args) >>= handleResponse -- | Call a remote method. remote :: Remote a =>- String -- ^ Server URL. May contain username and password on- -- the format username:password\@ before the hostname.+ String -- ^ Server URL. May contain username and password on+ -- the format username:password\@ before the hostname. -> String -- ^ Remote method name. -> a -- ^ Any function- -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>+ -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) => -- t1 -> ... -> tn -> IO r@ remote u m = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e) (call u m) -- | Call a remote method. Takes a list of extra headers to add to the HTTP -- request. remoteWithHeaders :: Remote a =>- String -- ^ Server URL. May contain username and password on- -- the format username:password\@ before the hostname.- -> String -- ^ Remote method name.- -> [Header] -- ^ Extra headers to add to HTTP request.- -> a -- ^ Any function- -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>- -- t1 -> ... -> tn -> IO r@+ String -- ^ Server URL. May contain username and password on+ -- the format username:password\@ before the hostname.+ -> String -- ^ Remote method name.+ -> [Header] -- ^ Extra headers to add to HTTP request.+ -> a -- ^ Any function+ -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>+ -- t1 -> ... -> tn -> IO r@ remoteWithHeaders u m headers = remote_ (\e -> "Error calling " ++ m ++ ": " ++ e)- (callWithHeaders u m headers)+ (callWithHeaders u m headers) class Remote a where remote_ :: (String -> String) -- ^ Will be applied to all error- -- messages.- -> ([Value] -> Err IO Value)- -> a+ -- messages.+ -> ([Value] -> Err IO Value)+ -> a instance XmlRpcType a => Remote (IO a) where remote_ h f = handleError (fail . h) $ f [] >>= fromValue@@ -165,25 +165,25 @@ eresp <- simpleHTTP (request uri auth headers (BS.concat . BSL.toChunks $ content)) resp <- handleE (fail . show) eresp case rspCode resp of- (2,0,0) -> return (U.toString (rspBody resp))- _ -> fail (httpError resp)+ (2,0,0) -> return (U.toString (rspBody resp))+ _ -> fail (httpError resp) where showRspCode (a,b,c) = map intToDigit [a,b,c] httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp -- | Create an XML-RPC compliant HTTP request. request :: URI -> URIAuth -> [Header] -> BS.ByteString -> Request BS.ByteString-request uri auth headers content = Request{ rqURI = uri,- rqMethod = POST,- rqHeaders = headers,- rqBody = content }+request uri auth usrHeaders content = Request{ rqURI = uri,+ rqMethod = POST,+ rqHeaders = headers,+ rqBody = content } where -- the HTTP module adds a Host header based on the URI headers = [Header HdrUserAgent userAgent,- Header HdrContentType "text/xml",- Header HdrContentLength (show (BS.length content))- ] ++ maybeToList (uncurry authHdr . parseUserInfo $ auth)- ++ headers+ Header HdrContentType "text/xml",+ Header HdrContentLength (show (BS.length content))+ ] ++ maybeToList (uncurry authHdr . parseUserInfo $ auth)+ ++ usrHeaders parseUserInfo info = let (u,pw) = break (==':') $ uriUserInfo info in ( if null u then Nothing else Just u , if null pw then Nothing else Just (tail pw))@@ -191,13 +191,13 @@ -- | Creates an Authorization header using the Basic scheme, -- see RFC 2617 section 2. authHdr :: Maybe String -- ^ User name, if any- -> Maybe String -- ^ Password, if any- -> Maybe Header -- ^ If user name or password was given, returns- -- an Authorization header, otherwise 'Nothing'+ -> Maybe String -- ^ Password, if any+ -> Maybe Header -- ^ If user name or password was given, returns+ -- an Authorization header, otherwise 'Nothing' authHdr Nothing Nothing = Nothing authHdr u p = Just (Header HdrAuthorization ("Basic " ++ base64encode user_pass))- where user_pass = fromMaybe "" u ++ ":" ++ fromMaybe "" p- base64encode = BS.unpack . Base64.encode . BS.pack+ where user_pass = fromMaybe "" u ++ ":" ++ fromMaybe "" p+ base64encode = BS.unpack . Base64.encode . BS.pack -- -- Utility functions
haxr.cabal view
@@ -1,5 +1,5 @@ Name: haxr-Version: 3000.9.2.1+Version: 3000.9.3 Cabal-version: >=1.10 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006