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


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

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


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

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


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

-- 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 (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
    --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: " 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"