    -----------------------------------------------------------------------------
    -- |
    -- 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
                                  v <- IO a -> Err IO a
    forall a. IO a -> Err IO a
    handleIO IO a
    x
                                  return (Return (toValue 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
                                      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
                                      toFun (f v) (MethodCall n 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 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)
                          return (renderResponse 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
        (method,_) <- 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)
        method 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
        (_,(as,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)
        return [map show (r:as)]

    methodHelp :: [(String,XmlRpcMethod)] -> String -> IO String
    methodHelp :: [(String, XmlRpcMethod)] -> String -> IO String
    methodHelp [(String, XmlRpcMethod)]
    t String
    name =
        do
        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)
        return (help 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
        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
        output <- server ms input
        putStr ("Server: " ++ serverName ++ crlf)
        putStr ("Content-Type: text/xml" ++ crlf)
        putStr ("Content-Length: " ++ show (B.length output) ++ crlf)
        putStr crlf
        B.putStr output
            where crlf :: String
    crlf = String
    "\r\n"