module Network.XmlRpc.Server
(
XmlRpcMethod, ServerResult,
fun,
handleCall, methods, cgiXmlRpcServer,
) where
import Network.XmlRpc.Internals
import qualified Codec.Binary.UTF8.String as U
import Control.Exception
import Control.Monad.Trans
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B
import System.IO
serverName :: String
serverName :: String
serverName = String
"Haskell XmlRpcServer/0.1"
type ServerResult = Err IO MethodResponse
type Signature = ([Type], Type)
type XmlRpcMethod = (MethodCall -> ServerResult, Signature)
showException :: SomeException -> String
showException :: SomeException -> String
showException = forall a. Show a => a -> String
show
handleIO :: IO a -> Err IO a
handleIO :: forall a. IO a -> Err IO a
handleIO IO a
io = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
showException) forall (m :: * -> *) a. Monad m => a -> m a
return
fun :: XmlRpcFun a => a -> XmlRpcMethod
fun :: forall a. XmlRpcFun a => a -> XmlRpcMethod
fun a
f = (forall a. XmlRpcFun a => a -> MethodCall -> ServerResult
toFun a
f, forall a. XmlRpcFun a => a -> Signature
sig a
f)
class XmlRpcFun a where
toFun :: a -> MethodCall -> ServerResult
sig :: a -> Signature
instance XmlRpcType a => XmlRpcFun (IO a) where
toFun :: IO a -> MethodCall -> ServerResult
toFun IO a
x (MethodCall String
_ []) = do
a
v <- forall a. IO a -> Err IO a
handleIO IO a
x
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MethodResponse
Return (forall a. XmlRpcType a => a -> Value
toValue a
v))
toFun IO a
_ MethodCall
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Too many arguments"
sig :: IO a -> Signature
sig IO a
x = ([], forall a. XmlRpcType a => a -> Type
getType (forall (m :: * -> *) a. m a -> a
mType IO a
x))
instance (XmlRpcType a, XmlRpcFun b) => XmlRpcFun (a -> b) where
toFun :: (a -> b) -> MethodCall -> ServerResult
toFun a -> b
f (MethodCall String
n (Value
x:[Value]
xs)) = do
a
v <- forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
x
forall a. XmlRpcFun a => a -> MethodCall -> ServerResult
toFun (a -> b
f a
v) (String -> [Value] -> MethodCall
MethodCall String
n [Value]
xs)
toFun a -> b
_ MethodCall
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Too few arguments"
sig :: (a -> b) -> Signature
sig a -> b
f = let (a
a,b
b) = forall a b. (a -> b) -> (a, b)
funType a -> b
f
([Type]
as, Type
r) = forall a. XmlRpcFun a => a -> Signature
sig b
b
in (forall a. XmlRpcType a => a -> Type
getType a
a forall a. a -> [a] -> [a]
: [Type]
as, Type
r)
mType :: m a -> a
mType :: forall (m :: * -> *) a. m a -> a
mType m a
_ = forall a. HasCallStack => a
undefined
funType :: (a -> b) -> (a, b)
funType :: forall a b. (a -> b) -> (a, b)
funType a -> b
_ = (forall a. HasCallStack => a
undefined, forall a. HasCallStack => a
undefined)
errorToResponse :: ServerResult -> IO MethodResponse
errorToResponse :: ServerResult -> IO MethodResponse
errorToResponse = forall (m :: * -> *) a.
MonadFail m =>
(String -> m a) -> Err m a -> m a
handleError (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> MethodResponse
Fault Int
0)
handleCall :: (MethodCall -> ServerResult) -> String -> IO ByteString
handleCall :: (MethodCall -> ServerResult) -> String -> IO ByteString
handleCall MethodCall -> ServerResult
f String
str = do MethodResponse
resp <- ServerResult -> IO MethodResponse
errorToResponse (forall e (m :: * -> *).
(Show e, MonadError e m, MonadFail m) =>
String -> Err m MethodCall
parseCall String
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MethodCall -> ServerResult
f)
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodResponse -> ByteString
renderResponse MethodResponse
resp)
methods :: [(String,XmlRpcMethod)] -> MethodCall -> ServerResult
methods :: [(String, XmlRpcMethod)] -> MethodCall -> ServerResult
methods [(String, XmlRpcMethod)]
t c :: MethodCall
c@(MethodCall String
name [Value]
_) =
do
(MethodCall -> ServerResult
method,Signature
_) <- forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown method: " forall a. [a] -> [a] -> [a]
++ String
name) (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, XmlRpcMethod)]
t)
MethodCall -> ServerResult
method MethodCall
c
server :: [(String,XmlRpcMethod)] -> String -> IO ByteString
server :: [(String, XmlRpcMethod)] -> String -> IO ByteString
server [(String, XmlRpcMethod)]
t = (MethodCall -> ServerResult) -> String -> IO ByteString
handleCall ([(String, XmlRpcMethod)] -> MethodCall -> ServerResult
methods ([(String, XmlRpcMethod)] -> [(String, XmlRpcMethod)]
addIntrospection [(String, XmlRpcMethod)]
t))
addIntrospection :: [(String,XmlRpcMethod)] -> [(String,XmlRpcMethod)]
addIntrospection :: [(String, XmlRpcMethod)] -> [(String, XmlRpcMethod)]
addIntrospection [(String, XmlRpcMethod)]
t = [(String, XmlRpcMethod)]
t'
where t' :: [(String, XmlRpcMethod)]
t' = (String
"system.listMethods", forall a. XmlRpcFun a => a -> XmlRpcMethod
fun ([(String, XmlRpcMethod)] -> IO [String]
listMethods [(String, XmlRpcMethod)]
t')) forall a. a -> [a] -> [a]
:
(String
"system.methodSignature", forall a. XmlRpcFun a => a -> XmlRpcMethod
fun ([(String, XmlRpcMethod)] -> String -> IO [[String]]
methodSignature [(String, XmlRpcMethod)]
t')) forall a. a -> [a] -> [a]
:
(String
"system.methodHelp", forall a. XmlRpcFun a => a -> XmlRpcMethod
fun ([(String, XmlRpcMethod)] -> String -> IO String
methodHelp [(String, XmlRpcMethod)]
t')) forall a. a -> [a] -> [a]
: [(String, XmlRpcMethod)]
t
listMethods :: [(String,XmlRpcMethod)] -> IO [String]
listMethods :: [(String, XmlRpcMethod)] -> IO [String]
listMethods [(String, XmlRpcMethod)]
t = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a, b) -> a
fst (forall a b. [(a, b)] -> ([a], [b])
unzip [(String, XmlRpcMethod)]
t))
methodSignature :: [(String,XmlRpcMethod)] -> String -> IO [[String]]
methodSignature :: [(String, XmlRpcMethod)] -> String -> IO [[String]]
methodSignature [(String, XmlRpcMethod)]
t String
name =
do
(MethodCall -> ServerResult
_,([Type]
as,Type
r)) <- forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown method: " forall a. [a] -> [a] -> [a]
++ String
name) (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, XmlRpcMethod)]
t)
forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show (Type
rforall a. a -> [a] -> [a]
:[Type]
as)]
methodHelp :: [(String,XmlRpcMethod)] -> String -> IO String
methodHelp :: [(String, XmlRpcMethod)] -> String -> IO String
methodHelp [(String, XmlRpcMethod)]
t String
name =
do
XmlRpcMethod
method <- forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown method: " forall a. [a] -> [a] -> [a]
++ String
name) (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, XmlRpcMethod)]
t)
forall (m :: * -> *) a. Monad m => a -> m a
return (XmlRpcMethod -> String
help XmlRpcMethod
method)
help :: XmlRpcMethod -> String
help :: XmlRpcMethod -> String
help XmlRpcMethod
_ = String
""
cgiXmlRpcServer :: [(String,XmlRpcMethod)] -> IO ()
cgiXmlRpcServer :: [(String, XmlRpcMethod)] -> IO ()
cgiXmlRpcServer [(String, XmlRpcMethod)]
ms =
do
Handle -> Bool -> IO ()
hSetBinaryMode Handle
stdin Bool
True
Handle -> Bool -> IO ()
hSetBinaryMode Handle
stdout Bool
True
String
input <- String -> String
U.decodeString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO String
getContents
ByteString
output <- [(String, XmlRpcMethod)] -> String -> IO ByteString
server [(String, XmlRpcMethod)]
ms String
input
String -> IO ()
putStr (String
"Server: " forall a. [a] -> [a] -> [a]
++ String
serverName forall a. [a] -> [a] -> [a]
++ String
crlf)
String -> IO ()
putStr (String
"Content-Type: text/xml" forall a. [a] -> [a] -> [a]
++ String
crlf)
String -> IO ()
putStr (String
"Content-Length: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ByteString -> Int64
B.length ByteString
output) forall a. [a] -> [a] -> [a]
++ String
crlf)
String -> IO ()
putStr String
crlf
ByteString -> IO ()
B.putStr ByteString
output
where crlf :: String
crlf = String
"\r\n"