diff --git a/Network/XmlRpc/Client.hs b/Network/XmlRpc/Client.hs --- a/Network/XmlRpc/Client.hs +++ b/Network/XmlRpc/Client.hs @@ -38,7 +38,7 @@ import qualified Network.XmlRpc.Base64 as Base64 import Network.XmlRpc.Internals -import Control.Exception (handleJust, userErrors) +import Control.Exception (handleJust) import Data.Char import Data.Maybe import Data.Word (Word8) @@ -48,6 +48,7 @@ import Network.HTTP import Network.Stream +import Data.ByteString.Lazy.Char8 (ByteString, toChunks, fromChunks) import qualified Data.ByteString.UTF8 as U import qualified Data.ByteString as BS @@ -120,7 +121,7 @@ -- | Post some content to a uri, return the content of the response -- or an error. -- FIXME: should we really use fail? -post :: String -> String -> IO String +post :: String -> ByteString -> IO String post url content = do uri <- maybeFail ("Bad URI: '" ++ url ++ "'") (parseURI url) let a = authority uri @@ -130,13 +131,13 @@ -- | Post some content to a uri, return the content of the response -- or an error. -- FIXME: should we really use fail? -post_ :: URI -> URIAuthority -> String -> IO String +post_ :: URI -> URIAuthority -> ByteString -> IO String post_ uri auth content = do -- FIXME: remove --putStrLn (show (request uri content)) --putStrLn content - eresp <- simpleHTTP (request uri auth (U.fromString content)) + eresp <- simpleHTTP (request uri auth (BS.concat . toChunks $ content)) resp <- handleE (fail . show) eresp case rspCode resp of (2,0,0) -> return (U.toString (rspBody resp)) diff --git a/Network/XmlRpc/Internals.hs b/Network/XmlRpc/Internals.hs --- a/Network/XmlRpc/Internals.hs +++ b/Network/XmlRpc/Internals.hs @@ -50,9 +50,8 @@ import System.IO.Unsafe (unsafePerformIO) import Text.XML.HaXml.XmlContent -import Text.XML.HaXml.Pretty -import Text.PrettyPrint.HughesPJ - +import Network.XmlRpc.Pretty +import Data.ByteString.Lazy.Char8 (ByteString, pack) import qualified Network.XmlRpc.Base64 as Base64 import qualified Network.XmlRpc.DTD_XMLRPC as XR @@ -99,14 +98,14 @@ type Err m a = ErrorT String m a -- | Evaluate the argument and catch error call exceptions -errorToErr :: Monad m => a -> Err m a -errorToErr x = let e = unsafePerformIO (tryJust errorCalls (evaluate x)) - in ErrorT (return e) +errorToErr :: (Show e, MonadError e m) => a -> Err m a +errorToErr x = unsafePerformIO (liftM return (evaluate x) `catch` handleErr) + where handleErr :: Monad m => SomeException -> IO (Err m a) + handleErr = return . throwError . show -- | Catch IO errors in the error monad. ioErrorToErr :: IO a -> Err IO a -ioErrorToErr = ErrorT . liftM (either (Left . show) Right) . tryJust ioErrors - +ioErrorToErr x = (liftIO x >>= return) `catchError` \e -> throwError (show e) -- | Handle errors from the error monad. handleError :: Monad m => (String -> m a) -> Err m a -> m a @@ -312,6 +311,39 @@ _ -> typeError v getType _ = TStruct +-- Tuple instances may be used for heterogenous array types. +instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d, + XmlRpcType e) => + XmlRpcType (a,b,c,d,e) where + toValue (v,w,x,y,z) = + ValueArray [toValue v, toValue w, toValue x, toValue y, toValue z] + fromValue (ValueArray [v,w,x,y,z]) = + liftM5 (,,,,) (fromValue v) (fromValue w) (fromValue x) + (fromValue y) (fromValue z) + fromValue _ = throwError "Expected 5-element tuple!" + getType _ = TArray + +instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d) => + XmlRpcType (a,b,c,d) where + toValue (w,x,y,z) = ValueArray [toValue w, toValue x, toValue y, toValue z] + fromValue (ValueArray [w,x,y,z]) = + liftM4 (,,,) (fromValue w) (fromValue x) (fromValue y) (fromValue z) + fromValue _ = throwError "Expected 4-element tuple!" + getType _ = TArray + +instance (XmlRpcType a, XmlRpcType b, XmlRpcType c) => XmlRpcType (a,b,c) where + toValue (x,y,z) = ValueArray [toValue x, toValue y, toValue z] + fromValue (ValueArray [x,y,z]) = + liftM3 (,,) (fromValue x) (fromValue y) (fromValue z) + fromValue _ = throwError "Expected 3-element tuple!" + getType _ = TArray + +instance (XmlRpcType a, XmlRpcType b) => XmlRpcType (a,b) where + toValue (x,y) = ValueArray [toValue x, toValue y] + fromValue (ValueArray [x,y]) = liftM2 (,) (fromValue x) (fromValue y) + fromValue _ = throwError "Expected 2-element tuple." + getType _ = TArray + -- | Get a field value from a (possibly heterogeneous) struct. getField :: (Monad m, XmlRpcType a) => String -- ^ Field name @@ -541,7 +573,7 @@ -- -- | Parses a method call from XML. -parseCall :: Monad m => String -> Err m MethodCall +parseCall :: (Show e, MonadError e m) => String -> Err m MethodCall parseCall c = do mxc <- errorToErr (readXml c) @@ -549,7 +581,7 @@ fromXRMethodCall xc -- | Parses a method response from XML. -parseResponse :: Monad m => String -> Err m MethodResponse +parseResponse :: (Show e, MonadError e m) => String -> Err m MethodResponse parseResponse c = do mxr <- errorToErr (readXml c) @@ -562,17 +594,15 @@ -- | Makes an XML-representation of a method call. -- FIXME: pretty prints ugly XML -renderCall :: MethodCall -> String +renderCall :: MethodCall -> ByteString renderCall = showXml' False . toXRMethodCall -- | Makes an XML-representation of a method response. -- FIXME: pretty prints ugly XML -renderResponse :: MethodResponse -> String +renderResponse :: MethodResponse -> ByteString renderResponse = showXml' False . toXRMethodResponse -showXml' :: XmlContent a => Bool -> a -> String -showXml' dtd x = - let st = style{ mode = LeftMode } - in case toContents x of - [CElem _ _] -> (renderStyle st . document . toXml dtd) x - _ -> "" +showXml' :: XmlContent a => Bool -> a -> ByteString +showXml' dtd x = case toContents x of + [CElem _ _] -> (document . toXml dtd) x + _ -> pack "" diff --git a/Network/XmlRpc/Pretty.hs b/Network/XmlRpc/Pretty.hs new file mode 100644 --- /dev/null +++ b/Network/XmlRpc/Pretty.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +module Network.XmlRpc.Pretty (document, content, element, + doctypedecl, prolog, cp) where +-- | This is a fast non-pretty-printer for turning the internal representation +-- of generic structured XML documents into Lazy ByteStrings. +-- Like in Text.Xml.HaXml.Pretty, there is one pp function for each type in +-- Text.Xml.HaXml.Types, so you can pretty-print as much or as little +-- of the document as you wish. + +import Prelude hiding (maybe, elem, concat, null, head) +import qualified Prelude as P +import Data.ByteString.Lazy.Char8 (ByteString(), elem, empty) +import qualified Data.ByteString.Lazy.UTF8 as BU +import Text.XML.HaXml.Types +import Blaze.ByteString.Builder hiding (empty) +import Blaze.ByteString.Builder.Char.Utf8 (fromString) +--import Data.Binary.Builder hiding (empty) +import Data.Maybe (isNothing) +import Data.Monoid +import qualified GHC.Exts as Ext + +-- |A 'Builder' with a recognizable empty value. +newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving Monoid + +-- |'Maybe' eliminator specialized for 'MBuilder'. +maybe :: (t -> MBuilder) -> Maybe t -> MBuilder +maybe _ Nothing = mempty +maybe f (Just x) = f x + +-- |Nullity predicate for 'MBuilder'. +null :: MBuilder -> Bool +null = isNothing . unMB + +-- |Helper for injecting 'ByteString's into 'MBuilder'. +fromLBS :: ByteString -> MBuilder +fromLBS = MBuilder . Just . fromLazyByteString + +-- Helper needed when using Data.Binary.Builder. +-- fromString :: String -> Builder +-- fromString = fromLazyByteString . BU.fromString + +-- |Support for the OverloadedStrings extension to improve templating +-- syntax. +instance Ext.IsString MBuilder where + fromString "" = mempty + fromString s = MBuilder . Just . fromString $ s + +-- A simple implementation of the pretty-printing combinator interface, +-- but for plain ByteStrings: +infixr 6 <> +infixr 6 <+> +infixr 5 $$ + +-- |Beside. +(<>) :: MBuilder -> MBuilder -> MBuilder +(<>) = mappend + +-- |Concatenate two 'MBuilder's with a single space in between +-- them. If either of the component 'MBuilder's is empty, then the +-- other is returned without any additional space. +(<+>) :: MBuilder -> MBuilder -> MBuilder +(<+>) b1 b2 + | null b2 = b1 + | null b1 = b2 + | otherwise = b1 <> " " <> b2 + +-- |Concatenate two 'MBuilder's with a single newline in between +-- them. If either of the component 'MBuilder's is empty, then the +-- other is returned without any additional newline. +($$) :: MBuilder -> MBuilder -> MBuilder +($$) b1 b2 + | null b2 = b1 + | null b1 = b2 + | otherwise = b1 <> "\n" <> b2 + +-- |Concatenate a list of 'MBuilder's with a given 'MBuilder' inserted +-- between each non-empty element of the list. +intercalate :: MBuilder -> [MBuilder] -> MBuilder +intercalate sep = aux . filter (not . null) + where aux [] = mempty + aux (x:xs) = x <> mconcat (map (sep <>) xs) + +-- |List version of '<+>'. +hsep :: [MBuilder] -> MBuilder +hsep = intercalate " " + +-- |List version of '$$'. +vcat :: [MBuilder] -> MBuilder +vcat = intercalate "\n" + +hcatMap :: (a -> MBuilder) -> [a] -> MBuilder +hcatMap = (mconcat .) . map + +vcatMap :: (a -> MBuilder) -> [a] -> MBuilder +vcatMap = (vcat .) . map + +-- |``Paragraph fill'' version of 'sep'. +fsep :: [MBuilder] -> MBuilder +fsep = hsep + +-- |Bracket an 'MBuilder' with parentheses. +parens :: MBuilder -> MBuilder +parens p = "(" <> p <> ")" + +text :: String -> MBuilder +text = MBuilder . Just . fromString + +---- +-- Now for the XML pretty-printing interface. +-- (Basically copied direct from Text.XML.HaXml.Pretty). + +-- |Render a 'Document' to a 'ByteString'. +document :: Document i -> ByteString +content :: Content i -> ByteString +element :: Element i -> ByteString +doctypedecl :: DocTypeDecl -> ByteString +prolog :: Prolog -> ByteString +cp :: CP -> ByteString + +-- Builder variants of exported functions. +documentB :: Document i -> MBuilder +contentB :: Content i -> MBuilder +elementB :: Element i -> MBuilder +doctypedeclB :: DocTypeDecl -> MBuilder +prologB :: Prolog -> MBuilder +cpB :: CP -> MBuilder + +xmldecl :: XMLDecl -> MBuilder +misc :: Misc -> MBuilder +sddecl :: Bool -> MBuilder +markupdecl :: MarkupDecl -> MBuilder +attribute :: Attribute -> MBuilder + +-- |Run an 'MBuilder' to generate a 'ByteString'. +runMBuilder :: MBuilder -> ByteString +runMBuilder = aux . unMB + where aux Nothing = empty + aux (Just b) = toLazyByteString b + +document = runMBuilder . documentB +content = runMBuilder . contentB +element = runMBuilder . elementB +doctypedecl = runMBuilder . doctypedeclB +prolog = runMBuilder . prologB +cp = runMBuilder . cpB + +documentB (Document p _ e m) = prologB p $$ elementB e $$ vcatMap misc m + +prologB (Prolog x m1 dtd m2) = maybe xmldecl x $$ + vcatMap misc m1 $$ + maybe doctypedeclB dtd $$ + vcatMap misc m2 + +xmldecl (XMLDecl v e sd) = " text v <> "'" <+> + maybe encodingdecl e <+> + maybe sddecl sd <+> "?>" + +misc (Comment s) = "" +misc (PI (n,s)) = " text n <+> text s <+> "?>" + +sddecl sd | sd = "standalone='yes'" + | otherwise = "standalone='no'" + +doctypedeclB (DTD n eid ds) = if P.null ds then hd <> ">" + else hd <+> " [" $$ vcatMap markupdecl ds $$ "]>" + where hd = " text n <+> maybe externalid eid + +markupdecl (Element e) = elementdecl e +markupdecl (AttList a) = attlistdecl a +markupdecl (Entity e) = entitydecl e +markupdecl (Notation n) = notationdecl n +markupdecl (MarkupMisc m) = misc m + +elementB (Elem n as []) = "<" <> (text n <+> fsep (map attribute as)) <> "/>" +elementB (Elem n as cs) + | isText (P.head cs) = "<" <> (text n <+> fsep (map attribute as)) <> ">" <> + hcatMap contentB cs <> " text n <> ">" + | otherwise = "<" <> (text n <+> fsep (map attribute as)) <> ">" <> + hcatMap contentB cs <> " text n <> ">" + +isText :: Content t -> Bool +isText (CString _ _ _) = True +isText (CRef _ _) = True +isText _ = False + +attribute (n,v) = text n <> "=" <> attvalue v + +contentB (CElem e _) = elementB e +contentB (CString False s _) = chardata s +contentB (CString True s _) = cdsect s +contentB (CRef r _) = reference r +contentB (CMisc m _) = misc m + +elementdecl :: ElementDecl -> MBuilder +elementdecl (ElementDecl n cs) = " text n <+> + contentspec cs <> ">" + +contentspec :: ContentSpec -> MBuilder +contentspec EMPTY = "EMPTY" +contentspec ANY = "ANY" +contentspec (Mixed m) = mixed m +contentspec (ContentSpec c) = cpB c + +cpB (TagName n m) = text n <> modifier m +cpB (Choice cs m) = parens (intercalate "|" (map cpB cs)) <> modifier m +cpB (Seq cs m) = parens (intercalate "," (map cpB cs)) <> modifier m + +modifier :: Modifier -> MBuilder +modifier None = mempty +modifier Query = "?" +modifier Star = "*" +modifier Plus = "+" + +mixed :: Mixed -> MBuilder +mixed PCDATA = "(#PCDATA)" +mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map text ns) <> ")*" + +attlistdecl :: AttListDecl -> MBuilder +attlistdecl (AttListDecl n ds) = " text n <+> + fsep (map attdef ds) <> ">" + +attdef :: AttDef -> MBuilder +attdef (AttDef n t d) = text n <+> atttype t <+> defaultdecl d + +atttype :: AttType -> MBuilder +atttype StringType = "CDATA" +atttype (TokenizedType t) = tokenizedtype t +atttype (EnumeratedType t) = enumeratedtype t + +tokenizedtype :: TokenizedType -> MBuilder +tokenizedtype ID = "ID" +tokenizedtype IDREF = "IDREF" +tokenizedtype IDREFS = "IDREFS" +tokenizedtype ENTITY = "ENTITY" +tokenizedtype ENTITIES = "ENTITIES" +tokenizedtype NMTOKEN = "NMTOKEN" +tokenizedtype NMTOKENS = "NMTOKENS" + +enumeratedtype :: EnumeratedType -> MBuilder +enumeratedtype (NotationType n) = notationtype n +enumeratedtype (Enumeration e) = enumeration e + +notationtype :: [[Char]] -> MBuilder +notationtype ns = "NOTATION" <+> + parens (intercalate "|" (map text ns)) + +enumeration :: [[Char]] -> MBuilder +enumeration ns = parens (intercalate "|" (map nmtoken ns)) + +defaultdecl :: DefaultDecl -> MBuilder +defaultdecl REQUIRED = "#REQUIRED" +defaultdecl IMPLIED = "#IMPLIED" +defaultdecl (DefaultTo a f) = maybe (const "#FIXED") f <+> attvalue a + +reference :: Reference -> MBuilder +reference (RefEntity er) = entityref er +reference (RefChar cr) = charref cr + +entityref :: [Char] -> MBuilder +entityref n = "&" <> text n <> ";" + +charref :: (Show a) => a -> MBuilder +charref c = "&#" <> text (show c) <> ";" + +entitydecl :: EntityDecl -> MBuilder +entitydecl (EntityGEDecl d) = gedecl d +entitydecl (EntityPEDecl d) = pedecl d + +gedecl :: GEDecl -> MBuilder +gedecl (GEDecl n ed) = " text n <+> entitydef ed <> ">" + +pedecl :: PEDecl -> MBuilder +pedecl (PEDecl n pd) = " text n <+> pedef pd <> ">" + +entitydef :: EntityDef -> MBuilder +entitydef (DefEntityValue ew) = entityvalue ew +entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd + +pedef :: PEDef -> MBuilder +pedef (PEDefEntityValue ew) = entityvalue ew +pedef (PEDefExternalID eid) = externalid eid + +externalid :: ExternalID -> MBuilder +externalid (SYSTEM sl) = "SYSTEM" <+> systemliteral sl +externalid (PUBLIC i sl) = "PUBLIC" <+> pubidliteral i <+> systemliteral sl + +ndatadecl :: NDataDecl -> MBuilder +ndatadecl (NDATA n) = "NDATA" <+> text n + +notationdecl :: NotationDecl -> MBuilder +notationdecl (NOTATION n e) = " text n <+> + either externalid publicid e <> ">" + +publicid :: PublicID -> MBuilder +publicid (PUBLICID p) = "PUBLICID" <+> pubidliteral p + +encodingdecl :: EncodingDecl -> MBuilder +encodingdecl (EncodingDecl s) = "encoding='" <> text s <> "'" + +nmtoken :: [Char] -> MBuilder +nmtoken s = text s + +attvalue :: AttValue -> MBuilder +attvalue (AttValue esr) = "\"" <> hcatMap attVal esr <> "\"" + where attVal = either text reference + +entityvalue :: EntityValue -> MBuilder +entityvalue (EntityValue evs) + | containsDoubleQuote evs = "'" <> hcatMap ev evs <> "'" + | otherwise = "\"" <> hcatMap ev evs <> "\"" + +ev :: EV -> MBuilder +ev (EVString s) = text s +ev (EVRef r) = reference r + +pubidliteral :: PubidLiteral -> MBuilder +pubidliteral (PubidLiteral s) + | '"' `elem` s' = "'" <> fromLBS s' <> "'" + | otherwise = "\"" <> fromLBS s' <> "\"" + where s' = BU.fromString s + +systemliteral :: SystemLiteral -> MBuilder +systemliteral (SystemLiteral s) + | '"' `elem` s' = "'" <> fromLBS s' <> "'" + | otherwise = "\"" <> fromLBS s' <> "\"" + where s' = BU.fromString s + +chardata, cdsect :: [Char] -> MBuilder +chardata s = {-if all isSpace s then empty else-} text s +cdsect c = " chardata c <> "]]>" + +containsDoubleQuote :: [EV] -> Bool +containsDoubleQuote evs = any csq evs + where csq (EVString s) = '"' `elem` BU.fromString s + csq _ = False diff --git a/Network/XmlRpc/Server.hs b/Network/XmlRpc/Server.hs --- a/Network/XmlRpc/Server.hs +++ b/Network/XmlRpc/Server.hs @@ -30,6 +30,8 @@ import Network.XmlRpc.Internals +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as B import Data.Maybe import Control.Monad.Error import Control.Exception @@ -49,8 +51,8 @@ -- | The type of XML-RPC methods on the server. type XmlRpcMethod = (MethodCall -> ServerResult, Signature) -showException :: Exception -> String -showException ex = fromMaybe (show ex) (userErrors ex) +showException :: SomeException -> String +showException = show handleIO :: IO a -> Err IO a handleIO io = lift (try io) >>= either (fail . showException) return @@ -100,10 +102,9 @@ -- | Reads a method call from a string, uses the supplied method -- to generate a response and returns that response as a string -handleCall :: (MethodCall -> ServerResult) -> String -> IO String -handleCall f str = do - resp <- errorToResponse (parseCall str >>= f) - return (renderResponse resp) +handleCall :: (MethodCall -> ServerResult) -> String -> IO ByteString +handleCall f str = do resp <- errorToResponse (parseCall str >>= f) + return (renderResponse resp) -- | An XmlRpcMethod that looks up the method name in a table -- and uses that method to handle the call. @@ -115,7 +116,7 @@ -- | A server with introspection support -server :: [(String,XmlRpcMethod)] -> String -> IO String +server :: [(String,XmlRpcMethod)] -> String -> IO ByteString server t = handleCall (methods (addIntrospection t)) @@ -164,10 +165,11 @@ hSetBinaryMode stdin True hSetBinaryMode stdout True input <- U.decodeString `fmap` getContents - output <- U.encodeString `fmap` server ms input + --output <- U.encodeString `fmap` server ms input + output <- server ms input putStr ("Server: " ++ serverName ++ crlf) putStr ("Content-Type: text/xml" ++ crlf) - putStr ("Content-Length: " ++ show (length output) ++ crlf) + putStr ("Content-Length: " ++ show (B.length output) ++ crlf) putStr crlf - putStr output + B.putStr output where crlf = "\r\n" diff --git a/haxr.cabal b/haxr.cabal --- a/haxr.cabal +++ b/haxr.cabal @@ -1,5 +1,5 @@ Name: haxr -Version: 3000.7 +Version: 3000.8 Cabal-version: >=1.6 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 @@ -21,21 +21,18 @@ examples/test_client.hs examples/test_server.hs examples/time-xmlrpc-com.hs examples/validate.hs examples/Makefile - -Flag old-base - description: Old, monolithic base - default: False - - Library - Build-depends: base < 4, mtl, network, HaXml >= 1.20 && < 1.21, HTTP >= 4000, dataenc, old-locale, - old-time, time, array, utf8-string, bytestring, pretty, template-haskell + Build-depends: base < 5, mtl, network < 3, + HaXml == 1.20.*, HTTP >= 4000, bytestring, dataenc, + old-locale, old-time, time, array, utf8-string, + template-haskell, blaze-builder == 0.2.* Exposed-Modules: Network.XmlRpc.Client, Network.XmlRpc.Server, Network.XmlRpc.Internals, Network.XmlRpc.Introspect, - Network.XmlRpc.THDeriveXmlRpcType + Network.XmlRpc.THDeriveXmlRpcType, + Network.XmlRpc.Pretty Other-Modules: Network.XmlRpc.Base64, Network.XmlRpc.DTD_XMLRPC