haxr 3000.5 → 3000.6

raw patch · 16 files changed

+515/−6 lines, 16 filesdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

API changes (from Hackage documentation)

Files

• Network/XmlRpc/THDeriveXmlRpcType.hs +100/−0
• examples/Makefile +20/−0
• examples/Person.hs +22/−0
• examples/PersonTH.hs +14/−0
• examples/make-stubs.hs +71/−0
• examples/parse_response.hs +9/−0
• examples/person_client.hs +13/−0
• examples/person_server.hs +13/−0
• examples/raw_call.hs +76/−0
• examples/simple_client.hs +14/−0
• examples/simple_server.hs +8/−0
• examples/test_client.hs +37/−0
• examples/test_server.hs +18/−0
• examples/time-xmlrpc-com.hs +11/−0
• examples/validate.hs +71/−0
• haxr.cabal +18/−6

@@ -0,0 +1,100 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.XmlRpc.THDeriveXmlRpcType+-- Copyright   :  (c) Bjorn Bringert 2003-2005+-- License     :  BSD-style+-- +-- Maintainer  :  bjorn@bringert.net+-- Stability   :  experimental+-- Portability :  non-portable (requires extensions and non-portable libraries)+--+-- Uses Template Haskell to automagically derive instances of 'XmlRpcType'+--+------------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell #-}+module Network.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) where++import Control.Monad (replicateM, liftM)+import Data.List (genericLength)+import Data.Maybe (maybeToList)+import Language.Haskell.TH+import Network.XmlRpc.Internals hiding (Type)++-- | Creates an 'XmlRpcType' instance which handles a Haskell record+--   as an XmlRpc struct. Example:+-- @+-- data Person = Person { name :: String, age :: Int }+-- $(asXmlRpcStruct \'\'Person)+-- @+asXmlRpcStruct :: Name -> Q [Dec]+asXmlRpcStruct name = +    do+    info <- reify name+    dec <- case info of+		     TyConI d -> return d+		     _ -> fail $ show name ++ " is not a type constructor"+    mkInstance dec++mkInstance :: Dec -> Q [Dec]+mkInstance  (DataD _ n _ [RecC c fs] _) = +    do+    let ns = (map (\ (f,_,t) -> (unqual f, isMaybe t)) fs)+    tv <- mkToValue ns +    fv <- mkFromValue c ns+    gt <- mkGetType+    liftM (:[]) $ instanceD (cxt []) (appT (conT ''XmlRpcType)+				    (conT n)) +	      (map return $ concat [tv, fv, gt])++mkInstance _ = error "Can only derive XML-RPC type for simple record types"+++isMaybe :: Type -> Bool+isMaybe (AppT (ConT n) _) | n == ''Maybe = True+isMaybe _ = False+++unqual :: Name -> Name+unqual = mkName . reverse . takeWhile (`notElem` [':','.']) . reverse . show++mkToValue :: [(Name,Bool)] -> Q [Dec]+mkToValue fs = +    do+    p <- newName "p"+    simpleFun 'toValue [varP p] +		(appE (varE 'toValue)+			  (appE [| concat |] $ listE $ map (fieldToTuple p) fs))+++simpleFun :: Name -> [PatQ] -> ExpQ -> Q [Dec]+simpleFun n ps b = sequence [funD n [clause ps (normalB b) []]]++fieldToTuple :: Name -> (Name,Bool) -> ExpQ+fieldToTuple p (n,False) = listE [tupE [stringE (show n), +					 appE (varE 'toValue)+					 (appE (varE n) (varE p))+					]+				 ]+fieldToTuple p (n,True) = +    [| map (\v -> ($(stringE (show n)), toValue v)) $ maybeToList $(appE (varE n) (varE p)) |]++mkFromValue :: Name -> [(Name,Bool)] -> Q [Dec]+mkFromValue c fs = +    do+    names <- replicateM (length fs) (newName "x")+    v <- newName "v"+    t <- newName "t"+    simpleFun 'fromValue [varP v] $ +	       doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] +++		      zipWith (mkGetField t) (map varP names) fs ++ +		      [noBindS $ appE [| return |] $ appsE (conE c:map varE names)]++mkGetField t p (f,False) = bindS p (appsE [varE 'getField, +					   stringE (show f), varE t])+mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe, +					  stringE (show f), varE t])++mkGetType :: Q [Dec]+mkGetType = simpleFun 'getType [wildP] +	     (conE 'TStruct)

@@ -0,0 +1,20 @@+GHC = ghc+GHCFLAGS = -O2 -package haxr -fallow-overlapping-instances++TEST_PROGS = make-stubs parse_response \+             person_server person_client raw_call \+	     simple_client simple_server test_client \+             test_server time-xmlrpc-com validate \+             person_server person_client++.SUFFIXES: .hs .hi .o++.PHONY: all clean++default all: $(TEST_PROGS)++%: %.hs+	$(GHC) $(GHCFLAGS) --make -o $@ $<++clean:+	-rm -f *.hi *.o $(TEST_PROGS)

@@ -0,0 +1,22 @@+-- | This module demonstrates how to handle heterogeneous structs.+--   See person_server.hs and person_client.hs for examples.+module Person where++import Network.XmlRpc.Internals++-- | Record type used to represent the struct in Haskell.+data Person = Person { name :: String, age :: Int, spouse :: Maybe String } deriving Show++-- | Converts a Person to and from a heterogeneous struct.+--   Uses the existing instance of XmlRpcType for [(String,Value)]+instance XmlRpcType Person where+    toValue p = toValue $ [("name",toValue (name p)),+			   ("age", toValue (age p))]+                           ++ maybe [] ((:[]) . (,) "spouse" . toValue) (spouse p)+    fromValue v = do+		  t <- fromValue v+		  n <- getField "name" t+		  a <- getField "age" t+		  s <- getFieldMaybe "spouse" t+		  return Person { name = n, age = a, spouse = s }+    getType _ = TStruct

@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fth #-}++-- | This module demonstrates how to handle heterogeneous structs+--   using Template Haskell.+--   See person_server.hs and person_client.hs for examples.+module PersonTH where++import Network.XmlRpc.Internals+import Network.XmlRpc.THDeriveXmlRpcType++-- | Record type used to represent the struct in Haskell.+data Person = Person { name :: String, age :: Int, spouse :: Maybe String } deriving Show++$(asXmlRpcStruct ''Person)

@@ -0,0 +1,71 @@+-- Connects to an XML-RPC server that supports introspection+-- and prints a Haskell module to standard output that contains+-- stubs for all the methods available at the server.++import Network.XmlRpc.Internals+import Network.XmlRpc.Client+import Network.XmlRpc.Introspect++import Data.List+import System.Exit (exitFailure)+import System.Environment (getArgs)+import System.IO +import Text.PrettyPrint.HughesPJ++showHaskellType :: Type -> String+showHaskellType TInt = "Int"+showHaskellType TBool = "Bool"+showHaskellType TString = "String"+showHaskellType TDouble = "Double"+showHaskellType TDateTime = "CalendarTime"+showHaskellType TBase64 = "String"+showHaskellType TStruct = "[(String,Value)]"+showHaskellType TArray = "[Value]"+showHaskellType TUnknown = error "unknown type"++showHdr :: String -> String -> Doc+showHdr mod url = text "module" <+> text mod <+> text "where" +                   $$ text "import Network.XmlRpc.Client" +                   $$ text "import Network.XmlRpc.Internals (Value)"+                   $$ text "import System.Time (CalendarTime)"+                   $$ text ""+                   $$ text "server :: String" +                   $$ text "server =" <+> doubleQuotes (text url)++showStub :: MethodInfo -> Doc+showStub (name,[(as,ret)],help) = +    text "" $$ text "{-" <+> text help <+> text "-}"+     $$ text hsname <+> text "::" <+> hsep (intersperse (text "->") ft)+     $$ text hsname <+> text "= remote server" <+> doubleQuotes (text name)+    where +    hsname = mkname name+    ft = map (text . showHaskellType) as +	 ++ [text "IO" <+> text (showHaskellType ret)]+    mkname [] = []+    mkname ('.':xs) = '_':mkname xs+    mkname (x:xs) = x:mkname xs+showStub (name, _, _) = error (name ++ " is overloaded")++printStub :: String -> String -> IO ()+printStub url method = methodInfo url method >>= putStrLn . show . showStub++printModule :: String -> String -> IO ()+printModule mod url = do+		      ms <- listMethods url+		      putStrLn $ show $ showHdr mod url+		      mapM_ (printStub url) ms++parseArgs :: IO (String,String)+parseArgs = do+	    args <- getArgs+	    case args of +		      [mod,url] -> return (mod,url)+		      _ -> do+			   hPutStrLn stderr "Usage: make-stubs module-name url"+			   exitFailure++main :: IO ()+main = do+       hSetBuffering stdout NoBuffering+       (mod,url) <- parseArgs+       printModule mod url

@@ -0,0 +1,9 @@+-- Reads a method response in XML from standard input and prints its+-- internal representation to standard output.++import Network.XmlRpc.Internals++main = do+       c <- getContents+       r <- handleError fail (parseResponse c)+       putStrLn (show r)

@@ -0,0 +1,13 @@+-- | Example client using a heterogeneous struct.++import Network.XmlRpc.Client+import PersonTH++server = "http://localhost/~bjorn/cgi-bin/person_server"++listPeople :: IO [Person]+listPeople = remote server "listPeople"++main = do+       people <- listPeople+       mapM_ print people

@@ -0,0 +1,13 @@+-- | Example server using a heterogeneous struct.++import Network.XmlRpc.Server+import PersonTH++listPeople :: IO [Person]+listPeople = return [+		     Person { name = "Homer Simpson", age = 38, +			      spouse = Just "Marge Simpson" },+		     Person { name = "Lisa Simpson", age = 8, spouse = Nothing}+		    ]++main = cgiXmlRpcServer [("listPeople", fun listPeople)]

@@ -0,0 +1,76 @@+-- Reads a method call in XML from standard input, sends it to a+-- server and prints the response to standard output. Must be editied +-- to use the right server URL.++import System (getArgs, exitFailure)+import IO (hPutStrLn, stderr)+import Data.Char+import Network.URI++import Network.XmlRpc.Internals+import Network.HTTP+import Network.Stream++parseArgs :: IO String+parseArgs = do+	    args <- getArgs+	    case args of +		      [url] -> return url+		      _ -> do+			   hPutStrLn stderr "Usage: raw_call url"+			   exitFailure++main = do+       url <- parseArgs+       c <- getContents+       post url c+       return ()++++userAgent :: String+userAgent = "Haskell XmlRpcClient/0.1"++-- | Handle connection errors.+handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a+handleE h (Left e) = h e+handleE _ (Right v) = return v++post :: String -> String -> IO String+post url content = +    case parseURI url of+		      Nothing -> fail ("Bad uri: '" ++ url ++ "'")+		      Just uri -> post_ uri content++post_ :: URI -> String -> IO String+post_ uri content = +    do+    putStrLn "-- Begin request --"+    putStrLn (show (request uri content))+    putStrLn content+    putStrLn "-- End request --"+    eresp <- simpleHTTP (request uri content)+    resp <- handleE (fail . show) eresp+    case rspCode resp of+		      (2,0,0) -> do+				 putStrLn "-- Begin response --"+				 putStrLn (show resp)+				 putStrLn (rspBody resp)+				 putStrLn "-- End response --"+				 return (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 -> String -> Request String+request uri 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 (length content))]

@@ -0,0 +1,14 @@+-- A client for simple_server++import Network.XmlRpc.Client++server = "http://localhost/~bjorn/cgi-bin/simple_server"++add :: String -> Int -> Int -> IO Int+add url = remote url "examples.add"++main = do+       let x = 4+	   y = 7+       z <- add server x y+       putStrLn (show x ++ " + " ++ show y ++ " = " ++ show z)

@@ -0,0 +1,8 @@+-- A minimal server++import Network.XmlRpc.Server++add :: Int -> Int -> IO Int+add x y = return (x + y)++main = cgiXmlRpcServer [("examples.add", fun add)]

@@ -0,0 +1,37 @@+-- A simple client that calls the methods in test_server.hs++import System (getArgs, exitFailure)+import IO (hPutStrLn, stderr)+import Time++import Network.XmlRpc.Client++time :: String -> IO CalendarTime+time url = remote url "examples.time"++add :: String -> Int -> Int -> IO Int+add url = remote url "examples.add"++fault :: String -> IO Int+fault url = remote url "echo.fault"+++parseArgs :: IO (String, Int, Int)+parseArgs = do+            args <- getArgs+            case args of+                      [url,x,y] -> return (url, read x, read y)+                      _ -> do+                           hPutStrLn stderr "Usage: test_client url x y"+                           exitFailure++main = do+       (url, x, y) <- parseArgs+       t <- time url+       putStrLn ("The server's current time is " ++ calendarTimeToString t) +       z <- add url x y+       putStrLn (show x ++ " + " ++ show y ++ " = " ++ show z)+       putStrLn "And now for an error:"+       fault url+       return ()+

@@ -0,0 +1,18 @@+-- A simple server++import Time+import Network.XmlRpc.Server++add :: Int -> Int -> IO Int+add x y = return (x + y)++time :: IO CalendarTime+time = getClockTime >>= toCalendarTime++fault :: IO Int -- dummy+fault = fail "blaha"++main = cgiXmlRpcServer [+     ("examples.add", fun add),+     ("echo.fault", fun fault),+     ("examples.time", fun time)]

@@ -0,0 +1,11 @@+import Network.XmlRpc.Client+import System.Time++server = "http://time.xmlrpc.com/RPC2"++currentTime :: IO CalendarTime+currentTime = remote server "currentTime.getCurrentTime"++main = do+       t <- currentTime+       putStrLn (calendarTimeToString t)

@@ -0,0 +1,71 @@+-- Implements the validation suite from http://validator.xmlrpc.com/+-- This has not been tested as the XML-RPC validator does not seem to +-- be working at the moment.++import System.Time+import Network.XmlRpc.Internals+import Network.XmlRpc.Server++get :: String -> [(String,a)] -> IO a+get f xs = maybeToM ("No such field: '" ++ f ++ "'") (lookup f xs)++arrayOfStructsTest :: [[(String,Int)]] -> IO Int +arrayOfStructsTest xs = return $ sum [ i | Just i <- map (lookup "curly") xs]++countTheEntities :: String -> IO [(String,Int)]+countTheEntities xs = return [+			      ("ctLeftAngleBrackets", count '<'),+			      ("ctRightAngleBrackets", count '>'),+			      ("ctAmpersands", count '&'),+			      ("ctApostrophes", count '\''),+			      ("ctQuotes", count '"')+			     ]+    where count c = length (filter (==c) xs)++easyStructTest :: [(String,Int)] -> IO Int +easyStructTest xs = do+		    m <- get "moe" xs+		    l <- get "larry" xs+		    c <- get "curly" xs+		    return (m+l+c)++-- FIXME: should be able to get it as a struct+echoStructTest :: Value -> IO Value+echoStructTest xs = return xs++manyTypesTest :: Int -> Bool -> String -> Double -> CalendarTime -> String+		 -> IO [Value]+manyTypesTest i b s d t b64 = return [toValue i, toValue b, toValue s,+				      toValue d, toValue t, toValue b64]++moderateSizeArrayCheck :: [String] -> IO String+moderateSizeArrayCheck [] = fail "empty array"+moderateSizeArrayCheck xs = return (head xs ++ last xs)++nestedStructTest :: [(String,[(String,[(String,[(String,Int)])])])] -> IO Int+nestedStructTest c = do+		      y <- get "2000" c+		      m <- get "04" y+		      d <- get "01" m+		      easyStructTest d+++simpleStructReturnTest :: Int -> IO [(String, Int)]+simpleStructReturnTest x = return [+				   ("times10",10*x),+				   ("times100",100*x),+				   ("times1000",1000*x)+				  ]++main = cgiXmlRpcServer +       [+	("validator1.arrayOfStructsTest", fun arrayOfStructsTest),+	("validator1.countTheEntities", fun countTheEntities),+	("validator1.easyStructTest", fun easyStructTest),+	("validator1.echoStructTest", fun echoStructTest),+	("validator1.manyTypesTest", fun manyTypesTest),+	("validator1.moderateSizeArrayCheck", fun moderateSizeArrayCheck),+	("validator1.nestedStructTest", fun nestedStructTest),+	("validator1.simpleStructReturnTest", fun simpleStructReturnTest)+       ]+

@@ -1,31 +1,43 @@ Name: haxr-Version: 3000.5-Cabal-version: >=1.2+Version: 3000.6+Cabal-version: >=1.6 Build-type: Simple Copyright: Bjorn Bringert, 2003-2006 License: BSD3 License-file: LICENSE Author: Bjorn Bringert <bjorn@bringert.net> Maintainer: Gracjan Polak <gracjanpolak@gmail.com>-Homepage: http://www.haskell.org/haxr/+Homepage: http://www.haskell.org/haskellwiki/HaXR Category: Network Synopsis: XML-RPC client and server library. Description:         HaXR is a library for writing XML-RPC          client and server applications in Haskell. +Extra-Source-Files:+        examples/make-stubs.hs        examples/parse_response.hs    examples/Person.hs+        examples/PersonTH.hs          examples/person_client.hs     examples/person_server.hs+        examples/raw_call.hs          examples/simple_client.hs     examples/simple_server.hs+        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+  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   Exposed-Modules:         Network.XmlRpc.Client,         Network.XmlRpc.Server,         Network.XmlRpc.Internals,-        Network.XmlRpc.Introspect+        Network.XmlRpc.Introspect,+        Network.XmlRpc.THDeriveXmlRpcType   Other-Modules:         Network.XmlRpc.Base64,         Network.XmlRpc.DTD_XMLRPC-  Extensions: OverlappingInstances, TypeSynonymInstances, FlexibleInstances+  Extensions: OverlappingInstances, TypeSynonymInstances, FlexibleInstances, TemplateHaskell+