haxr 3000.7 → 3000.8
raw patch · 5 files changed
+407/−42 lines, 5 filesdep +blaze-builderdep −prettydep ~basedep ~network
Dependencies added: blaze-builder
Dependencies removed: pretty
Dependency ranges changed: base, network
Files
- Network/XmlRpc/Client.hs +5/−4
- Network/XmlRpc/Internals.hs +48/−18
- Network/XmlRpc/Pretty.hs +335/−0
- Network/XmlRpc/Server.hs +12/−10
- haxr.cabal +7/−10
Network/XmlRpc/Client.hs view
@@ -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))
Network/XmlRpc/Internals.hs view
@@ -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 ""
+ Network/XmlRpc/Pretty.hs view
@@ -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) = "<?xml version='" <> text v <> "'" <+>+ maybe encodingdecl e <+>+ maybe sddecl sd <+> "?>"++misc (Comment s) = "<!--" <+> text 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 = "<!DOCTYPE" <+> 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) = "<!ELEMENT" <+> 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) = "<!ATTLIST" <+> 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) = "<!ENTITY" <+> text n <+> entitydef ed <> ">"++pedecl :: PEDecl -> MBuilder+pedecl (PEDecl n pd) = "<!ENTITY %" <> 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) = "<!NOTATION" <+> 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 = "<![CDATA[" <> chardata c <> "]]>"++containsDoubleQuote :: [EV] -> Bool+containsDoubleQuote evs = any csq evs+ where csq (EVString s) = '"' `elem` BU.fromString s+ csq _ = False
Network/XmlRpc/Server.hs view
@@ -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"
haxr.cabal view
@@ -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