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 = SomeException -> String
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 = IO (Either SomeException a)
-> ExceptT String IO (Either SomeException a)
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
io) ExceptT String IO (Either SomeException a)
-> (Either SomeException a -> ExceptT String IO a)
-> ExceptT String IO a
forall a b.
ExceptT String IO a
-> (a -> ExceptT String IO b) -> ExceptT String IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> ExceptT String IO a)
-> (a -> ExceptT String IO a)
-> Either SomeException a
-> ExceptT String IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ExceptT String IO a
forall a. String -> ExceptT String IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExceptT String IO a)
-> (SomeException -> String)
-> SomeException
-> ExceptT String IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
showException) a -> ExceptT String IO a
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
fun :: XmlRpcFun a => a -> XmlRpcMethod
fun :: forall a. XmlRpcFun a => a -> XmlRpcMethod
fun a
f = (a -> MethodCall -> ServerResult
forall a. XmlRpcFun a => a -> MethodCall -> ServerResult
toFun a
f, a -> Signature
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 <- IO a -> Err IO a
forall a. IO a -> Err IO a
handleIO IO a
x
MethodResponse -> ServerResult
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> MethodResponse
Return (a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
v))
toFun IO a
_ MethodCall
_ = String -> ServerResult
forall a. String -> ExceptT String IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Too many arguments"
sig :: IO a -> Signature
sig IO a
x = ([], a -> Type
forall a. XmlRpcType a => a -> Type
getType (IO a -> a
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 <- Value -> Err IO a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
x
b -> MethodCall -> ServerResult
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
_ = String -> ServerResult
forall a. String -> ExceptT String IO a
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) = (a -> b) -> (a, b)
forall a b. (a -> b) -> (a, b)
funType a -> b
f
([Type]
as, Type
r) = b -> Signature
forall a. XmlRpcFun a => a -> Signature
sig b
b
in (a -> Type
forall a. XmlRpcType a => a -> Type
getType a
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
as, Type
r)
mType :: m a -> a
mType :: forall (m :: * -> *) a. m a -> a
mType m a
_ = a
forall a. HasCallStack => a
undefined
funType :: (a -> b) -> (a, b)
funType :: forall a b. (a -> b) -> (a, b)
funType a -> b
_ = (a
forall a. HasCallStack => a
undefined, b
forall a. HasCallStack => a
undefined)
errorToResponse :: ServerResult -> IO MethodResponse
errorToResponse :: ServerResult -> IO MethodResponse
errorToResponse = (String -> IO MethodResponse) -> ServerResult -> IO MethodResponse
forall (m :: * -> *) a.
MonadFail m =>
(String -> m a) -> Err m a -> m a
handleError (MethodResponse -> IO MethodResponse
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MethodResponse -> IO MethodResponse)
-> (String -> MethodResponse) -> String -> IO MethodResponse
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 (String -> Err IO MethodCall
forall e (m :: * -> *).
(Show e, MonadError e m, MonadFail m) =>
String -> Err m MethodCall
parseCall String
str Err IO MethodCall -> (MethodCall -> ServerResult) -> ServerResult
forall a b.
ExceptT String IO a
-> (a -> ExceptT String IO b) -> ExceptT String IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MethodCall -> ServerResult
f)
ByteString -> IO ByteString
forall a. a -> IO a
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
_) <- String -> Maybe XmlRpcMethod -> ExceptT String IO XmlRpcMethod
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown method: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) (String -> [(String, XmlRpcMethod)] -> Maybe XmlRpcMethod
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", IO [String] -> XmlRpcMethod
forall a. XmlRpcFun a => a -> XmlRpcMethod
fun ([(String, XmlRpcMethod)] -> IO [String]
listMethods [(String, XmlRpcMethod)]
t')) (String, XmlRpcMethod)
-> [(String, XmlRpcMethod)] -> [(String, XmlRpcMethod)]
forall a. a -> [a] -> [a]
:
(String
"system.methodSignature", (String -> IO [[String]]) -> XmlRpcMethod
forall a. XmlRpcFun a => a -> XmlRpcMethod
fun ([(String, XmlRpcMethod)] -> String -> IO [[String]]
methodSignature [(String, XmlRpcMethod)]
t')) (String, XmlRpcMethod)
-> [(String, XmlRpcMethod)] -> [(String, XmlRpcMethod)]
forall a. a -> [a] -> [a]
:
(String
"system.methodHelp", (String -> IO String) -> XmlRpcMethod
forall a. XmlRpcFun a => a -> XmlRpcMethod
fun ([(String, XmlRpcMethod)] -> String -> IO String
methodHelp [(String, XmlRpcMethod)]
t')) (String, XmlRpcMethod)
-> [(String, XmlRpcMethod)] -> [(String, XmlRpcMethod)]
forall a. a -> [a] -> [a]
: [(String, XmlRpcMethod)]
t
listMethods :: [(String,XmlRpcMethod)] -> IO [String]
listMethods :: [(String, XmlRpcMethod)] -> IO [String]
listMethods [(String, XmlRpcMethod)]
t = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([String], [XmlRpcMethod]) -> [String]
forall a b. (a, b) -> a
fst ([(String, XmlRpcMethod)] -> ([String], [XmlRpcMethod])
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)) <- String -> Maybe XmlRpcMethod -> IO XmlRpcMethod
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown method: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) (String -> [(String, XmlRpcMethod)] -> Maybe XmlRpcMethod
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, XmlRpcMethod)]
t)
[[String]] -> IO [[String]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Type -> String) -> [Type] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Type -> String
forall a. Show a => a -> String
show (Type
rType -> [Type] -> [Type]
forall 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 <- String -> Maybe XmlRpcMethod -> IO XmlRpcMethod
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown method: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) (String -> [(String, XmlRpcMethod)] -> Maybe XmlRpcMethod
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, XmlRpcMethod)]
t)
String -> IO String
forall a. a -> IO a
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 (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
serverName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
crlf)
String -> IO ()
putStr (String
"Content-Type: text/xml" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
crlf)
String -> IO ()
putStr (String
"Content-Length: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
B.length ByteString
output) String -> String -> String
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"