-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XmlRpc.Server
-- Copyright   :  (c) Bjorn Bringert 2003
-- License     :  BSD-style
--
-- Maintainer  :  bjorn@bringert.net
-- Stability   :  experimental
-- Portability :  non-portable (requires extensions and non-portable libraries)
--
-- This module contains the server functionality of XML-RPC.
-- The XML-RPC specifcation is available at <http://www.xmlrpc.com/spec>.
--
-- A simple CGI-based XML-RPC server application:
--
-- > import Network.XmlRpc.Server
-- >
-- > add :: Int -> Int -> IO Int
-- > add x y = return (x + y)
-- >
-- > main = cgiXmlRpcServer [("examples.add", fun add)]
-----------------------------------------------------------------------------

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"

--
-- API
--

type ServerResult = Err IO MethodResponse

type Signature = ([Type], Type)

-- | The type of XML-RPC methods on the server.
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


--
-- Converting Haskell functions to XML-RPC methods
--

-- | Turns any function
--   @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>
--   t1 -> ... -> tn -> IO r@
--   into an 'XmlRpcMethod'
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)

-- FIXME: always returns error code 0
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)


-- | 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 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)

-- | An XmlRpcMethod that looks up the method name in a table
--   and uses that method to handle the call.
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


-- | A server with introspection support
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))



--
-- Introspection
--

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)

-- FIXME: implement
help :: XmlRpcMethod -> String
help :: XmlRpcMethod -> String
help XmlRpcMethod
_ = String
""


--
-- CGI server
--

-- | A CGI-based XML-RPC server. Reads a request from standard input
--   and writes some HTTP headers (Content-Type and Content-Length),
--   followed by the response to standard output. Supports
--   introspection.
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
    --output <- U.encodeString `fmap` server ms input
    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"