{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Network.XmlRpc.Internals
-- 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 core functionality of the XML-RPC library.
-- Most applications should not need to use this module. Client
-- applications should use "Network.XmlRpc.Client" and server applications should
-- use "Network.XmlRpc.Server".
--
-- The XML-RPC specifcation is available at <http://www.xmlrpc.com/spec>.
--
-----------------------------------------------------------------------------

#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_  {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

module Network.XmlRpc.Internals (
-- * Method calls and repsonses
MethodCall(..), MethodResponse(..),
-- * XML-RPC types
Value(..), Type(..), XmlRpcType(..),
-- * Converting from XML
parseResponse, parseCall, getField, getFieldMaybe,
-- * Converting to XML
renderCall, renderResponse,
-- * Converting to and from DTD types
toXRValue, fromXRValue,
toXRMethodCall, fromXRMethodCall,
toXRMethodResponse, fromXRMethodResponse,
toXRParams, fromXRParams,
toXRMember, fromXRMember,
-- * Error monad
Err, maybeToM, handleError, ioErrorToErr
) where

import           Control.Exception
import           Control.Monad
import           Control.Monad.Except (ExceptT, MonadError(..), runExceptT)
import qualified Control.Monad.Fail as Fail
import           Control.Monad.Fail (MonadFail)
import           Control.Monad.IO.Class
import           Control.Monad.Trans
import           Data.Char
import           Data.List
import           Data.Maybe
import           Data.Time.Calendar
import           Data.Time.Calendar.OrdinalDate (toOrdinalDate)
import           Data.Time.Calendar.WeekDate (toWeekDate)
import           Data.Time.Format
import           Data.Time.LocalTime
import           Numeric (showFFloat)
import           Prelude hiding (showString, catch)
import           System.IO.Unsafe (unsafePerformIO)
import           System.Time (CalendarTime(..))

#if ! MIN_VERSION_time(1,5,0)
import           System.Locale (defaultTimeLocale)
#endif

import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack)
import qualified Data.ByteString.Lazy.Char8 as BSL (ByteString, pack)
import qualified Network.XmlRpc.Base64 as Base64
import qualified Network.XmlRpc.DTD_XMLRPC as XR
import           Network.XmlRpc.Pretty
import           Text.XML.HaXml.XmlContent

--
-- General utilities
--

-- | Replaces all occurances of a sublist in a list with another list.
--   If the list to replace is the empty list, does nothing.
replace :: Eq a =>
        [a] -- ^ The sublist to replace when found
        -> [a] -- ^ The list to replace it with
        -> [a] -- ^ The list to replace in
        -> [a] -- ^ The result
replace :: forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [] [a]
_ [a]
xs = [a]
xs
replace [a]
_ [a]
_ [] = []
replace [a]
ys [a]
zs xs :: [a]
xs@(a
x:[a]
xs')
    | [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
ys [a]
xs = [a]
zs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
ys [a]
zs (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys) [a]
xs)
    | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
ys [a]
zs [a]
xs'

-- | Convert a 'Maybe' value to a value in any monad
maybeToM :: MonadFail m =>
                String -- ^ Error message to fail with for 'Nothing'
             -> Maybe a -- ^ The 'Maybe' value.
             -> m a -- ^ The resulting value in the monad.
maybeToM :: forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM String
err Maybe a
Nothing = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err
maybeToM String
_ (Just a
x) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Convert a 'Maybe' value to a value in any monad
eitherToM :: MonadFail m
          => String -- ^ Error message to fail with for 'Nothing'
          -> Either String a -- ^ The 'Maybe' value.
          -> m a -- ^ The resulting value in the monad.
eitherToM :: forall (m :: * -> *) a.
MonadFail m =>
String -> Either String a -> m a
eitherToM String
err (Left String
s)  = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
eitherToM   String
_ (Right a
x) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | The format for \"dateTime.iso8601\"
xmlRpcDateFormat :: String
xmlRpcDateFormat :: String
xmlRpcDateFormat = String
"%Y%m%dT%H:%M:%S"

--
-- Error monad stuff
--

type Err m a = ExceptT String m a

-- | Evaluate the argument and catch error call exceptions
errorToErr :: (Show e, MonadError e m) => a -> Err m a
errorToErr :: forall e (m :: * -> *) a. (Show e, MonadError e m) => a -> Err m a
errorToErr a
x = IO (Err m a) -> Err m a
forall a. IO a -> a
unsafePerformIO ((a -> Err m a) -> IO a -> IO (Err m a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Err m a
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a
forall a. a -> IO a
evaluate a
x) IO (Err m a) -> (SomeException -> IO (Err m a)) -> IO (Err m a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO (Err m a)
forall (m :: * -> *) a. Monad m => SomeException -> IO (Err m a)
handleErr)
  where handleErr :: Monad m => SomeException -> IO (Err m a)
        handleErr :: forall (m :: * -> *) a. Monad m => SomeException -> IO (Err m a)
handleErr = Err m a -> IO (Err m a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Err m a -> IO (Err m a))
-> (SomeException -> Err m a) -> SomeException -> IO (Err m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err m a
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Err m a)
-> (SomeException -> String) -> SomeException -> Err m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show

-- | Catch IO errors in the error monad.
ioErrorToErr :: IO a -> Err IO a
ioErrorToErr :: forall a. IO a -> Err IO a
ioErrorToErr IO a
x = (IO a -> ExceptT String IO a
forall a. IO a -> Err IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
x ExceptT String IO a
-> (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
>>= a -> ExceptT String IO a
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return) ExceptT String IO a
-> (String -> ExceptT String IO a) -> ExceptT String IO a
forall a.
ExceptT String IO a
-> (String -> ExceptT String IO a) -> ExceptT String IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \String
e -> String -> ExceptT String IO a
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> String
forall a. Show a => a -> String
show String
e)

-- | Handle errors from the error monad.
handleError :: MonadFail m => (String -> m a) -> Err m a -> m a
handleError :: forall (m :: * -> *) a.
MonadFail m =>
(String -> m a) -> Err m a -> m a
handleError String -> m a
h Err m a
m = do
                  Right a
x <- Err m a -> m (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Err m a -> (String -> Err m a) -> Err m a
forall a.
ExceptT String m a
-> (String -> ExceptT String m a) -> ExceptT String m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError Err m a
m (m a -> Err m 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 (m a -> Err m a) -> (String -> m a) -> String -> Err m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
h))
                  a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

errorRead :: (MonadFail m, Read a) =>
             ReadS a -- ^ Parser
          -> String -- ^ Error message
          -> String -- ^ String to parse
          -> Err m a
errorRead :: forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead ReadS a
r String
err String
s = case [a
x | (a
x,String
t) <- ReadS a
r String
s, (String
"",String
"") <- ReadS String
lex String
t] of
                          [a
x] -> a -> Err m a
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
                          [a]
_   -> String -> Err m a
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")

--
-- Types for methods calls and responses
--

-- | An XML-RPC method call. Consists of a method name and a list of
--   parameters.
data MethodCall = MethodCall String [Value]
                  deriving (MethodCall -> MethodCall -> Bool
(MethodCall -> MethodCall -> Bool)
-> (MethodCall -> MethodCall -> Bool) -> Eq MethodCall
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MethodCall -> MethodCall -> Bool
== :: MethodCall -> MethodCall -> Bool
$c/= :: MethodCall -> MethodCall -> Bool
/= :: MethodCall -> MethodCall -> Bool
Eq, Int -> MethodCall -> String -> String
[MethodCall] -> String -> String
MethodCall -> String
(Int -> MethodCall -> String -> String)
-> (MethodCall -> String)
-> ([MethodCall] -> String -> String)
-> Show MethodCall
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MethodCall -> String -> String
showsPrec :: Int -> MethodCall -> String -> String
$cshow :: MethodCall -> String
show :: MethodCall -> String
$cshowList :: [MethodCall] -> String -> String
showList :: [MethodCall] -> String -> String
Show) -- for debugging

-- | An XML-RPC response.
data MethodResponse = Return Value -- ^ A method response returning a value
                    | Fault Int String -- ^ A fault response
                      deriving (MethodResponse -> MethodResponse -> Bool
(MethodResponse -> MethodResponse -> Bool)
-> (MethodResponse -> MethodResponse -> Bool) -> Eq MethodResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MethodResponse -> MethodResponse -> Bool
== :: MethodResponse -> MethodResponse -> Bool
$c/= :: MethodResponse -> MethodResponse -> Bool
/= :: MethodResponse -> MethodResponse -> Bool
Eq, Int -> MethodResponse -> String -> String
[MethodResponse] -> String -> String
MethodResponse -> String
(Int -> MethodResponse -> String -> String)
-> (MethodResponse -> String)
-> ([MethodResponse] -> String -> String)
-> Show MethodResponse
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MethodResponse -> String -> String
showsPrec :: Int -> MethodResponse -> String -> String
$cshow :: MethodResponse -> String
show :: MethodResponse -> String
$cshowList :: [MethodResponse] -> String -> String
showList :: [MethodResponse] -> String -> String
Show) -- for debugging

-- | An XML-RPC value.
data Value =
      ValueInt Int -- ^ int, i4, or i8
    | ValueBool Bool -- ^ bool
    | ValueString String -- ^ string
    | ValueUnwrapped String -- ^ no inner element
    | ValueDouble Double -- ^ double
    | ValueDateTime LocalTime -- ^ dateTime.iso8601
    | ValueBase64 BS.ByteString -- ^ base 64.  NOTE that you should provide the raw data; the haxr library takes care of doing the base-64 encoding.
    | ValueStruct [(String,Value)] -- ^ struct
    | ValueArray [Value]  -- ^ array
    | ValueNil -- ^ nil
      deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, Int -> Value -> String -> String
[Value] -> String -> String
Value -> String
(Int -> Value -> String -> String)
-> (Value -> String) -> ([Value] -> String -> String) -> Show Value
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Value -> String -> String
showsPrec :: Int -> Value -> String -> String
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> String -> String
showList :: [Value] -> String -> String
Show) -- for debugging

-- | An XML-RPC value. Use for error messages and introspection.
data Type =
          TInt
          | TBool
          | TString
          | TDouble
          | TDateTime
          | TBase64
          | TStruct
          | TArray
          | TUnknown
          | TNil
      deriving (Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
/= :: Type -> Type -> Bool
Eq)

instance Show Type where
    show :: Type -> String
show Type
TInt = String
"int"
    show Type
TBool = String
"bool"
    show Type
TString = String
"string"
    show Type
TDouble = String
"double"
    show Type
TDateTime = String
"dateTime.iso8601"
    show Type
TBase64 = String
"base64"
    show Type
TStruct = String
"struct"
    show Type
TArray = String
"array"
    show Type
TUnknown = String
"unknown"
    show Type
TNil = String
"nil"

instance Read Type where
    readsPrec :: Int -> ReadS Type
readsPrec Int
_ String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
s) of
                    (String
"int",String
r) -> [(Type
TInt,String
r)]
                    (String
"bool",String
r) -> [(Type
TBool,String
r)]
                    (String
"string",String
r) -> [(Type
TString,String
r)]
                    (String
"double",String
r) -> [(Type
TDouble,String
r)]
                    (String
"dateTime.iso8601",String
r) -> [(Type
TDateTime,String
r)]
                    (String
"base64",String
r) -> [(Type
TBase64,String
r)]
                    (String
"struct",String
r) -> [(Type
TStruct,String
r)]
                    (String
"array",String
r) -> [(Type
TArray,String
r)]
                    (String
"nil",String
r) -> [(Type
TNil,String
r)]

-- | Gets the value of a struct member
structGetValue :: MonadFail m => String -> Value -> Err m Value
structGetValue :: forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue String
n (ValueStruct [(String, Value)]
t) =
    String -> Maybe Value -> ExceptT String m Value
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown member '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") (String -> [(String, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [(String, Value)]
t)
structGetValue String
_ Value
_ = String -> ExceptT String m Value
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Value is not a struct"

-- | Builds a fault struct
faultStruct :: Int -> String -> Value
faultStruct :: Int -> String -> Value
faultStruct Int
code String
str = [(String, Value)] -> Value
ValueStruct [(String
"faultCode",Int -> Value
ValueInt Int
code),
                                    (String
"faultString",String -> Value
ValueString String
str)]

-- XML-RPC specification:
-- "The body of the response is a single XML structure, a
-- <methodResponse>, which can contain a single <params> which contains a
-- single <param> which contains a single <value>."
onlyOneResult :: MonadFail m => [Value] -> Err m Value
onlyOneResult :: forall (m :: * -> *). MonadFail m => [Value] -> Err m Value
onlyOneResult [] = String -> ExceptT String m Value
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"Method returned no result"
onlyOneResult [Value
x] = Value -> ExceptT String m Value
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
onlyOneResult [Value]
_ = String -> ExceptT String m Value
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"Method returned more than one result"

--
-- Converting to and from XML-RPC types
--

-- | A class for mapping Haskell types to XML-RPC types.
class XmlRpcType a where
    -- | Convert from this type to a 'Value'
    toValue :: a -> Value
    -- | Convert from a 'Value' to this type. May fail if
    --   if there is a type error.
    fromValue :: MonadFail m => Value -> Err m a
    getType :: a -> Type

typeError :: (XmlRpcType a, MonadFail m) => Value -> Err m a
typeError :: forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v = (a -> Err m a) -> Err m a
forall a (m :: * -> *). (a -> Err m a) -> Err m a
withType ((a -> Err m a) -> Err m a) -> (a -> Err m a) -> Err m a
forall a b. (a -> b) -> a -> b
$ \a
t ->
       String -> Err m a
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Wanted: "
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show (a -> Type
forall a. XmlRpcType a => a -> Type
getType a
t)
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"', got: '"
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> Value -> String
forall a. XmlContent a => Bool -> a -> String
showXml Bool
False (Value -> Value
toXRValue Value
v) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") Err m a -> Err m a -> Err m a
forall a. a -> a -> a
`asTypeOf` a -> Err m a
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t

-- a type hack for use in 'typeError'
withType :: (a -> Err m a) -> Err m a
withType :: forall a (m :: * -> *). (a -> Err m a) -> Err m a
withType a -> Err m a
f = a -> Err m a
f a
forall a. HasCallStack => a
undefined

simpleFromValue :: (MonadFail m, XmlRpcType a) => (Value -> Maybe a)
                -> Value -> Err m a
simpleFromValue :: forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe a
f Value
v =
    Err m a -> (a -> Err m a) -> Maybe a -> Err m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Value -> Err m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v) a -> Err m a
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Maybe a
f Value
v)


-- | Exists to allow explicit type conversions.
instance XmlRpcType Value where
    toValue :: Value -> Value
toValue = Value -> Value
forall a. a -> a
id
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromValue = Value -> ExceptT String m Value
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT String m Value)
-> (Value -> Value) -> Value -> ExceptT String m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
forall a. a -> a
id
    getType :: Value -> Type
getType Value
_ = Type
TUnknown

-- FIXME: instance for ()?


instance XmlRpcType Int where
    toValue :: Int -> Value
toValue = Int -> Value
ValueInt
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Int
fromValue = (Value -> Maybe Int) -> Value -> Err m Int
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe Int
f
        where f :: Value -> Maybe Int
f (ValueInt Int
x) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
              f Value
_ = Maybe Int
forall a. Maybe a
Nothing
    getType :: Int -> Type
getType Int
_ = Type
TInt

instance XmlRpcType Bool where
    toValue :: Bool -> Value
toValue = Bool -> Value
ValueBool
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Bool
fromValue = (Value -> Maybe Bool) -> Value -> Err m Bool
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe Bool
f
        where f :: Value -> Maybe Bool
f (ValueBool Bool
x) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x
              f Value
_ = Maybe Bool
forall a. Maybe a
Nothing
    getType :: Bool -> Type
getType Bool
_ = Type
TBool

instance OVERLAPPING_ XmlRpcType String where
    toValue :: String -> Value
toValue = String -> Value
ValueString
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m String
fromValue = (Value -> Maybe String) -> Value -> Err m String
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe String
f
        where f :: Value -> Maybe String
f (ValueString String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
              f (ValueUnwrapped String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
              f Value
_ = Maybe String
forall a. Maybe a
Nothing
    getType :: String -> Type
getType String
_ = Type
TString

instance XmlRpcType Text where
    toValue :: Text -> Value
toValue = String -> Value
ValueString (String -> Value) -> (Text -> String) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Text
fromValue = ((String -> Text)
-> ExceptT String m String -> ExceptT String m Text
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Text
T.pack) (ExceptT String m String -> ExceptT String m Text)
-> (Value -> ExceptT String m String)
-> Value
-> ExceptT String m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ExceptT String m String
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m String
fromValue
    getType :: Text -> Type
getType Text
_ = Type
TString

instance XmlRpcType BS.ByteString where
    toValue :: ByteString -> Value
toValue = ByteString -> Value
ValueBase64
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m ByteString
fromValue = (Value -> Maybe ByteString) -> Value -> Err m ByteString
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe ByteString
f
        where f :: Value -> Maybe ByteString
f (ValueBase64 ByteString
x) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x
              f Value
_ = Maybe ByteString
forall a. Maybe a
Nothing
    getType :: ByteString -> Type
getType ByteString
_ = Type
TBase64

instance XmlRpcType Double where
    toValue :: Double -> Value
toValue = Double -> Value
ValueDouble
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Double
fromValue = (Value -> Maybe Double) -> Value -> Err m Double
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe Double
f
        where f :: Value -> Maybe Double
f (ValueDouble Double
x) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x
              f Value
_ = Maybe Double
forall a. Maybe a
Nothing
    getType :: Double -> Type
getType Double
_ = Type
TDouble

instance XmlRpcType LocalTime where
    toValue :: LocalTime -> Value
toValue = LocalTime -> Value
ValueDateTime
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m LocalTime
fromValue = (Value -> Maybe LocalTime) -> Value -> Err m LocalTime
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe LocalTime
f
        where f :: Value -> Maybe LocalTime
f (ValueDateTime LocalTime
x) = LocalTime -> Maybe LocalTime
forall a. a -> Maybe a
Just LocalTime
x
              f Value
_ = Maybe LocalTime
forall a. Maybe a
Nothing
    getType :: LocalTime -> Type
getType LocalTime
_ = Type
TDateTime

instance XmlRpcType CalendarTime where
    toValue :: CalendarTime -> Value
toValue = LocalTime -> Value
forall a. XmlRpcType a => a -> Value
toValue (LocalTime -> Value)
-> (CalendarTime -> LocalTime) -> CalendarTime -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalendarTime -> LocalTime
calendarTimeToLocalTime
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m CalendarTime
fromValue = (LocalTime -> CalendarTime)
-> ExceptT String m LocalTime -> ExceptT String m CalendarTime
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LocalTime -> CalendarTime
localTimeToCalendarTime (ExceptT String m LocalTime -> ExceptT String m CalendarTime)
-> (Value -> ExceptT String m LocalTime)
-> Value
-> ExceptT String m CalendarTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ExceptT String m LocalTime
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m LocalTime
fromValue
    getType :: CalendarTime -> Type
getType CalendarTime
_ = Type
TDateTime

instance XmlRpcType () where
    toValue :: () -> Value
toValue = Value -> () -> Value
forall a b. a -> b -> a
const Value
ValueNil
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m ()
fromValue = (Value -> Maybe ()) -> Value -> Err m ()
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe ()
f
        where f :: Value -> Maybe ()
f Value
ValueNil = () -> Maybe ()
forall a. a -> Maybe a
Just ()
              f Value
_ = Maybe ()
forall a. Maybe a
Nothing
    getType :: () -> Type
getType ()
_ = Type
TNil

-- FIXME: array elements may have different types
instance OVERLAPPABLE_ XmlRpcType a => XmlRpcType [a] where
    toValue :: [a] -> Value
toValue = [Value] -> Value
ValueArray ([Value] -> Value) -> ([a] -> [Value]) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. XmlRpcType a => a -> Value
toValue
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m [a]
fromValue Value
v = case Value
v of
                         ValueArray [Value]
xs -> (Value -> ExceptT String m a) -> [Value] -> Err m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue [Value]
xs
                         Value
_ -> Value -> Err m [a]
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v
    getType :: [a] -> Type
getType [a]
_ = Type
TArray

-- FIXME: struct elements may have different types
instance OVERLAPPING_ XmlRpcType a => XmlRpcType [(String,a)] where
    toValue :: [(String, a)] -> Value
toValue [(String, a)]
xs = [(String, Value)] -> Value
ValueStruct [(String
n, a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
v) | (String
n,a
v) <- [(String, a)]
xs]

    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m [(String, a)]
fromValue Value
v = case Value
v of
                  ValueStruct [(String, Value)]
xs -> ((String, Value) -> ExceptT String m (String, a))
-> [(String, Value)] -> Err m [(String, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (String
n,Value
v') -> (a -> (String, a))
-> ExceptT String m a -> ExceptT String m (String, a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) String
n) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
v')) [(String, Value)]
xs
                  Value
_ -> Value -> Err m [(String, a)]
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v
    getType :: [(String, a)] -> Type
getType [(String, a)]
_ = Type
TStruct

-- Tuple instances may be used for heterogenous array types.
instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d,
          XmlRpcType e) =>
         XmlRpcType (a,b,c,d,e) where
    toValue :: (a, b, c, d, e) -> Value
toValue (a
v,b
w,c
x,d
y,e
z) =
        [Value] -> Value
ValueArray [a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
v, b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
w, c -> Value
forall a. XmlRpcType a => a -> Value
toValue c
x, d -> Value
forall a. XmlRpcType a => a -> Value
toValue d
y, e -> Value
forall a. XmlRpcType a => a -> Value
toValue e
z]
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (a, b, c, d, e)
fromValue (ValueArray [Value
v,Value
w,Value
x,Value
y,Value
z]) =
        (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m c
-> ExceptT String m d
-> ExceptT String m e
-> ExceptT String m (a, b, c, d, e)
forall (m :: * -> *) a1 a2 a3 a4 a5 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> a5 -> r)
-> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
liftM5 (,,,,) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
v) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m b
fromValue Value
w) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m c
fromValue Value
x)
                      (Value -> ExceptT String m d
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m d
fromValue Value
y) (Value -> ExceptT String m e
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m e
fromValue Value
z)
    fromValue Value
_ = String -> ExceptT String m (a, b, c, d, e)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expected 5-element tuple!"
    getType :: (a, b, c, d, e) -> Type
getType (a, b, c, d, e)
_ = Type
TArray

instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d) =>
         XmlRpcType (a,b,c,d) where
    toValue :: (a, b, c, d) -> Value
toValue (a
w,b
x,c
y,d
z) = [Value] -> Value
ValueArray [a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
w, b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
x, c -> Value
forall a. XmlRpcType a => a -> Value
toValue c
y, d -> Value
forall a. XmlRpcType a => a -> Value
toValue d
z]
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (a, b, c, d)
fromValue (ValueArray [Value
w,Value
x,Value
y,Value
z]) =
        (a -> b -> c -> d -> (a, b, c, d))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m c
-> ExceptT String m d
-> ExceptT String m (a, b, c, d)
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
w) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m b
fromValue Value
x) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m c
fromValue Value
y) (Value -> ExceptT String m d
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m d
fromValue Value
z)
    fromValue Value
_ = String -> ExceptT String m (a, b, c, d)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expected 4-element tuple!"
    getType :: (a, b, c, d) -> Type
getType (a, b, c, d)
_ = Type
TArray

instance (XmlRpcType a, XmlRpcType b, XmlRpcType c) => XmlRpcType (a,b,c) where
    toValue :: (a, b, c) -> Value
toValue (a
x,b
y,c
z) = [Value] -> Value
ValueArray [a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
x, b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
y, c -> Value
forall a. XmlRpcType a => a -> Value
toValue c
z]
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (a, b, c)
fromValue (ValueArray [Value
x,Value
y,Value
z]) =
        (a -> b -> c -> (a, b, c))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m c
-> ExceptT String m (a, b, c)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (,,) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
x) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m b
fromValue Value
y) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m c
fromValue Value
z)
    fromValue Value
_ = String -> ExceptT String m (a, b, c)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expected 3-element tuple!"
    getType :: (a, b, c) -> Type
getType (a, b, c)
_ = Type
TArray

instance (XmlRpcType a, XmlRpcType b) => XmlRpcType (a,b) where
    toValue :: (a, b) -> Value
toValue (a
x,b
y) = [Value] -> Value
ValueArray [a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
x, b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
y]
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (a, b)
fromValue (ValueArray [Value
x,Value
y]) = (a -> b -> (a, b))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m (a, b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
x) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m b
fromValue Value
y)
    fromValue Value
_ = String -> ExceptT String m (a, b)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expected 2-element tuple."
    getType :: (a, b) -> Type
getType (a, b)
_ = Type
TArray

-- | Get a field value from a (possibly heterogeneous) struct.
getField :: (MonadFail m, XmlRpcType a) =>
            String           -- ^ Field name
         -> [(String,Value)] -- ^ Struct
         -> Err m a
getField :: forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
String -> [(String, Value)] -> Err m a
getField String
x [(String, Value)]
xs = String -> Maybe Value -> ExceptT String m Value
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"struct member " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found")
                (String -> [(String, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Value)]
xs) ExceptT String m Value
-> (Value -> ExceptT String m a) -> ExceptT String m a
forall a b.
ExceptT String m a
-> (a -> ExceptT String m b) -> ExceptT String m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue

-- | Get a field value from a (possibly heterogeneous) struct.
getFieldMaybe :: (MonadFail m, XmlRpcType a) =>
            String           -- ^ Field name
         -> [(String,Value)] -- ^ Struct
         -> Err m (Maybe a)
getFieldMaybe :: forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
String -> [(String, Value)] -> Err m (Maybe a)
getFieldMaybe String
x [(String, Value)]
xs = case String -> [(String, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Value)]
xs of
                                      Maybe Value
Nothing -> Maybe a -> Err m (Maybe a)
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                                      Just Value
v -> (a -> Maybe a) -> ExceptT String m a -> Err m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
v)

--
-- Converting to XR types
--

toXRValue :: Value -> XR.Value
toXRValue :: Value -> Value
toXRValue (ValueInt Int
x) = [Value_] -> Value
XR.Value [AInt -> Value_
XR.Value_AInt (String -> AInt
XR.AInt (Int -> String
showInt Int
x))]
toXRValue (ValueBool Bool
b) = [Value_] -> Value
XR.Value [Boolean -> Value_
XR.Value_Boolean (String -> Boolean
XR.Boolean (Bool -> String
showBool Bool
b))]
toXRValue (ValueString String
s) = [Value_] -> Value
XR.Value [AString -> Value_
XR.Value_AString (String -> AString
XR.AString (String -> String
showString String
s))]
toXRValue (ValueUnwrapped String
s) = [Value_] -> Value
XR.Value [String -> Value_
XR.Value_Str String
s]
toXRValue (ValueDouble Double
d) = [Value_] -> Value
XR.Value [ADouble -> Value_
XR.Value_ADouble (String -> ADouble
XR.ADouble (Double -> String
showDouble Double
d))]
toXRValue (ValueDateTime LocalTime
t) =
   [Value_] -> Value
XR.Value [ DateTime_iso8601 -> Value_
XR.Value_DateTime_iso8601 (String -> DateTime_iso8601
XR.DateTime_iso8601 (LocalTime -> String
showDateTime LocalTime
t))]
toXRValue (ValueBase64 ByteString
s) = [Value_] -> Value
XR.Value [Base64 -> Value_
XR.Value_Base64 (String -> Base64
XR.Base64 (ByteString -> String
showBase64 ByteString
s))]
toXRValue (ValueStruct [(String, Value)]
xs) = [Value_] -> Value
XR.Value [Struct -> Value_
XR.Value_Struct ([Member] -> Struct
XR.Struct (((String, Value) -> Member) -> [(String, Value)] -> [Member]
forall a b. (a -> b) -> [a] -> [b]
map (String, Value) -> Member
toXRMember [(String, Value)]
xs))]
toXRValue (ValueArray [Value]
xs) =
    [Value_] -> Value
XR.Value [Array -> Value_
XR.Value_Array (Data -> Array
XR.Array ([Value] -> Data
XR.Data ((Value -> Value) -> [Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Value
toXRValue [Value]
xs)))]
toXRValue Value
ValueNil = [Value_] -> Value
XR.Value [Nil -> Value_
XR.Value_Nil (() -> Nil
XR.Nil ())]

showInt :: Int -> String
showInt :: Int -> String
showInt = Int -> String
forall a. Show a => a -> String
show

showBool :: Bool -> String
showBool :: Bool -> String
showBool Bool
b = if Bool
b then String
"1" else String
"0"

-- escapes &, <, and <
showString :: String -> String
showString :: String -> String
showString = String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
">" String
"&gt;" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"<" String
"&lt;" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&" String
"&amp;"

-- | Shows a double in signed decimal point notation.
showDouble :: Double -> String
showDouble :: Double -> String
showDouble Double
d = Maybe Int -> Double -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showFFloat Maybe Int
forall a. Maybe a
Nothing Double
d String
""

-- | Shows a date and time on the format: YYYYMMDDTHH:mm:SS
showDateTime :: LocalTime -> String
showDateTime :: LocalTime -> String
showDateTime LocalTime
t = TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
xmlRpcDateFormat LocalTime
t

showBase64 :: BS.ByteString -> String
showBase64 :: ByteString -> String
showBase64 = ByteString -> String
BS.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode

toXRMethodCall :: MethodCall -> XR.MethodCall
toXRMethodCall :: MethodCall -> MethodCall
toXRMethodCall (MethodCall String
name [Value]
vs) =
    MethodName -> Maybe Params -> MethodCall
XR.MethodCall (String -> MethodName
XR.MethodName String
name) (Params -> Maybe Params
forall a. a -> Maybe a
Just ([Value] -> Params
toXRParams [Value]
vs))

toXRMethodResponse :: MethodResponse -> XR.MethodResponse
toXRMethodResponse :: MethodResponse -> MethodResponse
toXRMethodResponse (Return Value
val) = Params -> MethodResponse
XR.MethodResponseParams ([Value] -> Params
toXRParams [Value
val])
toXRMethodResponse (Fault Int
code String
str) =
    Fault -> MethodResponse
XR.MethodResponseFault (Value -> Fault
XR.Fault (Value -> Value
toXRValue (Int -> String -> Value
faultStruct Int
code String
str)))

toXRParams :: [Value] -> XR.Params
toXRParams :: [Value] -> Params
toXRParams [Value]
vs = [Param] -> Params
XR.Params ((Value -> Param) -> [Value] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (Value -> Param
XR.Param (Value -> Param) -> (Value -> Value) -> Value -> Param
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
toXRValue) [Value]
vs)

toXRMember :: (String, Value) -> XR.Member
toXRMember :: (String, Value) -> Member
toXRMember (String
n, Value
v) = Name -> Value -> Member
XR.Member (String -> Name
XR.Name String
n) (Value -> Value
toXRValue Value
v)

--
-- Converting from XR types
--

fromXRValue :: MonadFail m => XR.Value -> Err m Value
fromXRValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue (XR.Value [Value_]
vs)
  =  case ((Value_ -> Bool) -> [Value_] -> [Value_]
forall a. (a -> Bool) -> [a] -> [a]
filter Value_ -> Bool
notstr [Value_]
vs) of
       []     -> ([String] -> Value) -> ExceptT String m [String] -> Err m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM  (String -> Value
ValueUnwrapped (String -> Value) -> ([String] -> String) -> [String] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ((Value_ -> ExceptT String m String)
-> [Value_] -> ExceptT String m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> ExceptT String m String
forall (m :: * -> *). Monad m => String -> Err m String
readString (String -> ExceptT String m String)
-> (Value_ -> String) -> Value_ -> ExceptT String m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value_ -> String
unstr) [Value_]
vs)
       (Value_
v:[Value_]
_)  -> Value_ -> Err m Value
forall {m :: * -> *}.
MonadFail m =>
Value_ -> ExceptT String m Value
f Value_
v
  where
  notstr :: Value_ -> Bool
notstr (XR.Value_Str String
_)  = Bool
False
  notstr Value_
_                 = Bool
True

  unstr :: Value_ -> String
unstr (XR.Value_Str String
x)  = String
x

  f :: Value_ -> ExceptT String m Value
f (XR.Value_I4 (XR.I4 String
x)) = (Int -> Value) -> ExceptT String m Int -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (String -> ExceptT String m Int
forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
  f (XR.Value_I8 (XR.I8 String
x)) = (Int -> Value) -> ExceptT String m Int -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (String -> ExceptT String m Int
forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
  f (XR.Value_AInt (XR.AInt String
x)) = (Int -> Value) -> ExceptT String m Int -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (String -> ExceptT String m Int
forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
  f (XR.Value_Boolean (XR.Boolean String
x)) = (Bool -> Value) -> ExceptT String m Bool -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Value
ValueBool (String -> ExceptT String m Bool
forall (m :: * -> *). MonadFail m => String -> Err m Bool
readBool String
x)
  f (XR.Value_ADouble (XR.ADouble String
x)) = (Double -> Value)
-> ExceptT String m Double -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Double -> Value
ValueDouble (String -> ExceptT String m Double
forall (m :: * -> *). MonadFail m => String -> Err m Double
readDouble String
x)
  f (XR.Value_AString (XR.AString String
x)) = (String -> Value)
-> ExceptT String m String -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Value
ValueString (String -> ExceptT String m String
forall (m :: * -> *). Monad m => String -> Err m String
readString String
x)
  f (XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 String
x)) =
    (LocalTime -> Value)
-> ExceptT String m LocalTime -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LocalTime -> Value
ValueDateTime (String -> ExceptT String m LocalTime
forall (m :: * -> *). MonadFail m => String -> Err m LocalTime
readDateTime String
x)
  f (XR.Value_Base64 (XR.Base64 String
x)) = (ByteString -> Value)
-> ExceptT String m ByteString -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> Value
ValueBase64 (String -> ExceptT String m ByteString
forall (m :: * -> *). Monad m => String -> Err m ByteString
readBase64 String
x)
  f (XR.Value_Struct (XR.Struct [Member]
ms)) =
    ([(String, Value)] -> Value)
-> ExceptT String m [(String, Value)] -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(String, Value)] -> Value
ValueStruct ((Member -> ExceptT String m (String, Value))
-> [Member] -> ExceptT String m [(String, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Member -> ExceptT String m (String, Value)
forall (m :: * -> *).
MonadFail m =>
Member -> Err m (String, Value)
fromXRMember [Member]
ms)
  f (XR.Value_Array (XR.Array (XR.Data [Value]
xs))) =
    ([Value] -> Value)
-> ExceptT String m [Value] -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Value] -> Value
ValueArray ((Value -> ExceptT String m Value)
-> [Value] -> ExceptT String m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue [Value]
xs)
  f (XR.Value_Nil (XR.Nil ()
x)) = Value -> ExceptT String m Value
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
ValueNil


fromXRMember :: MonadFail m => XR.Member -> Err m (String,Value)
fromXRMember :: forall (m :: * -> *).
MonadFail m =>
Member -> Err m (String, Value)
fromXRMember (XR.Member (XR.Name String
n) Value
xv) = (Value -> (String, Value))
-> ExceptT String m Value -> ExceptT String m (String, Value)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\Value
v -> (String
n,Value
v)) (Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue Value
xv)

-- | From the XML-RPC specification:
--
-- \"An integer is a 32-bit signed number. You can include a plus or
-- minus at the beginning of a string of numeric characters. Leading
-- zeros are collapsed. Whitespace is not permitted. Just numeric
-- characters preceeded by a plus or minus.\"
readInt :: MonadFail m => String -> Err m Int
readInt :: forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
s = ReadS Int -> String -> String -> Err m Int
forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead ReadS Int
forall a. Read a => ReadS a
reads String
"Error parsing integer" String
s


-- | From the XML-RPC specification:
--
-- \"0 (false) or 1 (true)\"
readBool :: MonadFail m => String -> Err m Bool
readBool :: forall (m :: * -> *). MonadFail m => String -> Err m Bool
readBool String
s = ReadS Bool -> String -> String -> Err m Bool
forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead ReadS Bool
readsBool String
"Error parsing boolean" String
s
    where readsBool :: ReadS Bool
readsBool String
"true" = [(Bool
True,String
"")]
          readsBool String
"false" = [(Bool
False,String
"")]
          readsBool String
"1" = [(Bool
True,String
"")]
          readsBool String
"0" = [(Bool
False,String
"")]
          readsBool String
_ = []

-- | From the XML-RPC specification:
--
-- \"Any characters are allowed in a string except \< and &, which are
-- encoded as &lt; and &amp;. A string can be used to encode binary data.\"
--
-- To work with implementations (such as some Python bindings for example)
-- which also escape \>, &gt; is unescaped. This is non-standard, but
-- seems unlikely to cause problems.
readString :: Monad m => String -> Err m String
readString :: forall (m :: * -> *). Monad m => String -> Err m String
readString = String -> ExceptT String m String
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ExceptT String m String)
-> (String -> String) -> String -> ExceptT String m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&amp;" String
"&" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&lt;" String
"<"
             (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&gt;" String
">"


-- | From the XML-RPC specification:
--
-- There is no representation for infinity or negative infinity or \"not
-- a number\". At this time, only decimal point notation is allowed, a
-- plus or a minus, followed by any number of numeric characters,
-- followed by a period and any number of numeric
-- characters. Whitespace is not allowed. The range of allowable values
-- is implementation-dependent, is not specified.
--
-- FIXME: accepts more than decimal point notation
readDouble :: MonadFail m => String -> Err m Double
readDouble :: forall (m :: * -> *). MonadFail m => String -> Err m Double
readDouble String
s = ReadS Double -> String -> String -> Err m Double
forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead ReadS Double
forall a. Read a => ReadS a
reads String
"Error parsing double" String
s

-- | From <http://groups.yahoo.com/group/xml-rpc/message/4733>:
--
--   \"Essentially \"dateTime.iso8601\" is a misnomer and the format of the
--   content of this element should not be assumed to comply with the
--   variants of the ISO8601 standard. Only assume YYYYMMDDTHH:mm:SS\"
-- FIXME: make more robust
readDateTime :: MonadFail m => String -> Err m LocalTime
readDateTime :: forall (m :: * -> *). MonadFail m => String -> Err m LocalTime
readDateTime String
dt =
    Err m LocalTime
-> (LocalTime -> Err m LocalTime)
-> Maybe LocalTime
-> Err m LocalTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (String -> Err m LocalTime
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> Err m LocalTime) -> String -> Err m LocalTime
forall a b. (a -> b) -> a -> b
$ String
"Error parsing dateTime '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
        LocalTime -> Err m LocalTime
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return
        (Bool -> TimeLocale -> String -> String -> Maybe LocalTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
xmlRpcDateFormat String
dt)

localTimeToCalendarTime :: LocalTime -> CalendarTime
localTimeToCalendarTime :: LocalTime -> CalendarTime
localTimeToCalendarTime LocalTime
l =
    let (Year
y,Int
mo,Int
d) = Day -> (Year, Int, Int)
toGregorian (LocalTime -> Day
localDay LocalTime
l)
        TimeOfDay { todHour :: TimeOfDay -> Int
todHour = Int
h, todMin :: TimeOfDay -> Int
todMin = Int
mi, todSec :: TimeOfDay -> Pico
todSec = Pico
s } = LocalTime -> TimeOfDay
localTimeOfDay LocalTime
l
        (Year
_,Int
_,Int
wd) = Day -> (Year, Int, Int)
toWeekDate (LocalTime -> Day
localDay LocalTime
l)
        (Year
_,Int
yd) = Day -> (Year, Int)
toOrdinalDate (LocalTime -> Day
localDay LocalTime
l)
     in CalendarTime {
                      ctYear :: Int
ctYear    = Year -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
y,
                      ctMonth :: Month
ctMonth   = Int -> Month
forall a. Enum a => Int -> a
toEnum (Int
moInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1),
                      ctDay :: Int
ctDay     = Int
d,
                      ctHour :: Int
ctHour    = Int
h,
                      ctMin :: Int
ctMin     = Int
mi,
                      ctSec :: Int
ctSec     = Pico -> Int
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Pico
s,
                      ctPicosec :: Year
ctPicosec = Year
0,
                      ctWDay :: Day
ctWDay    = Int -> Day
forall a. Enum a => Int -> a
toEnum (Int
wd Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7),
                      ctYDay :: Int
ctYDay    = Int
yd,
                      ctTZName :: String
ctTZName  = String
"UTC",
                      ctTZ :: Int
ctTZ      = Int
0,
                      ctIsDST :: Bool
ctIsDST   = Bool
False
                     }

calendarTimeToLocalTime :: CalendarTime -> LocalTime
calendarTimeToLocalTime :: CalendarTime -> LocalTime
calendarTimeToLocalTime CalendarTime
ct =
    let (Int
y,Month
mo,Int
d) = (CalendarTime -> Int
ctYear CalendarTime
ct, CalendarTime -> Month
ctMonth CalendarTime
ct, CalendarTime -> Int
ctDay CalendarTime
ct)
        (Int
h,Int
mi,Int
s) = (CalendarTime -> Int
ctHour CalendarTime
ct, CalendarTime -> Int
ctMin CalendarTime
ct, CalendarTime -> Int
ctSec CalendarTime
ct)
     in LocalTime {
                   localDay :: Day
localDay = Year -> Int -> Int -> Day
fromGregorian (Int -> Year
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) (Month -> Int
forall a. Enum a => a -> Int
fromEnum Month
mo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
d,
                   localTimeOfDay :: TimeOfDay
localTimeOfDay = TimeOfDay { todHour :: Int
todHour = Int
h, todMin :: Int
todMin = Int
mi, todSec :: Pico
todSec = Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s }
                  }

-- FIXME: what if data contains non-base64 characters?
readBase64 :: Monad m => String -> Err m BS.ByteString
readBase64 :: forall (m :: * -> *). Monad m => String -> Err m ByteString
readBase64 = ByteString -> ExceptT String m ByteString
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ExceptT String m ByteString)
-> (String -> ByteString) -> String -> ExceptT String m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.decode (ByteString -> ByteString)
-> (String -> ByteString) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack

fromXRParams :: MonadFail m => XR.Params -> Err m [Value]
fromXRParams :: forall (m :: * -> *). MonadFail m => Params -> Err m [Value]
fromXRParams (XR.Params [Param]
xps) = (Param -> ExceptT String m Value)
-> [Param] -> ExceptT String m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(XR.Param Value
v) -> Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue Value
v) [Param]
xps

fromXRMethodCall :: MonadFail m => XR.MethodCall -> Err m MethodCall
fromXRMethodCall :: forall (m :: * -> *). MonadFail m => MethodCall -> Err m MethodCall
fromXRMethodCall (XR.MethodCall (XR.MethodName String
name) Maybe Params
params) =
    ([Value] -> MethodCall)
-> ExceptT String m [Value] -> ExceptT String m MethodCall
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> [Value] -> MethodCall
MethodCall String
name) (Params -> ExceptT String m [Value]
forall (m :: * -> *). MonadFail m => Params -> Err m [Value]
fromXRParams (Params -> Maybe Params -> Params
forall a. a -> Maybe a -> a
fromMaybe ([Param] -> Params
XR.Params []) Maybe Params
params))

fromXRMethodResponse :: MonadFail m => XR.MethodResponse -> Err m MethodResponse
fromXRMethodResponse :: forall (m :: * -> *).
MonadFail m =>
MethodResponse -> Err m MethodResponse
fromXRMethodResponse (XR.MethodResponseParams Params
xps) =
    (Value -> MethodResponse)
-> ExceptT String m Value -> ExceptT String m MethodResponse
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Value -> MethodResponse
Return (Params -> Err m [Value]
forall (m :: * -> *). MonadFail m => Params -> Err m [Value]
fromXRParams Params
xps Err m [Value]
-> ([Value] -> ExceptT String m Value) -> ExceptT String m Value
forall a b.
ExceptT String m a
-> (a -> ExceptT String m b) -> ExceptT String m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Value] -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => [Value] -> Err m Value
onlyOneResult)
fromXRMethodResponse (XR.MethodResponseFault (XR.Fault Value
v)) =
    do
    Value
struct <- Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue Value
v
    Value
vcode <- String -> Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue String
"faultCode" Value
struct
    Int
code <- Value -> Err m Int
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m Int
fromValue Value
vcode
    Value
vstr <- String -> Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue String
"faultString" Value
struct
    String
str <- Value -> Err m String
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m String
fromValue Value
vstr
    MethodResponse -> ExceptT String m MethodResponse
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> MethodResponse
Fault Int
code String
str)

--
-- Parsing calls and reponses from XML
--

-- | Parses a method call from XML.
parseCall :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodCall
parseCall :: forall e (m :: * -> *).
(Show e, MonadError e m, MonadFail m) =>
String -> Err m MethodCall
parseCall String
c =
    do
    Either String MethodCall
mxc <- Either String MethodCall -> Err m (Either String MethodCall)
forall e (m :: * -> *) a. (Show e, MonadError e m) => a -> Err m a
errorToErr (String -> Either String MethodCall
forall a. XmlContent a => String -> Either String a
readXml String
c)
    MethodCall
xc <- String -> Either String MethodCall -> ExceptT String m MethodCall
forall (m :: * -> *) a.
MonadFail m =>
String -> Either String a -> m a
eitherToM String
"Error parsing method call" Either String MethodCall
mxc
    MethodCall -> Err m MethodCall
forall (m :: * -> *). MonadFail m => MethodCall -> Err m MethodCall
fromXRMethodCall MethodCall
xc

-- | Parses a method response from XML.
parseResponse :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodResponse
parseResponse :: forall e (m :: * -> *).
(Show e, MonadError e m, MonadFail m) =>
String -> Err m MethodResponse
parseResponse String
c =
    do
    Either String MethodResponse
mxr <- Either String MethodResponse
-> Err m (Either String MethodResponse)
forall e (m :: * -> *) a. (Show e, MonadError e m) => a -> Err m a
errorToErr (String -> Either String MethodResponse
forall a. XmlContent a => String -> Either String a
readXml String
c)
    MethodResponse
xr <- String
-> Either String MethodResponse -> ExceptT String m MethodResponse
forall (m :: * -> *) a.
MonadFail m =>
String -> Either String a -> m a
eitherToM String
"Error parsing method response" Either String MethodResponse
mxr
    MethodResponse -> Err m MethodResponse
forall (m :: * -> *).
MonadFail m =>
MethodResponse -> Err m MethodResponse
fromXRMethodResponse MethodResponse
xr

--
-- Rendering calls and reponses to XML
--

-- | Makes an XML-representation of a method call.
-- FIXME: pretty prints ugly XML
renderCall :: MethodCall -> BSL.ByteString
renderCall :: MethodCall -> ByteString
renderCall = Bool -> MethodCall -> ByteString
forall a. XmlContent a => Bool -> a -> ByteString
showXml' Bool
False (MethodCall -> ByteString)
-> (MethodCall -> MethodCall) -> MethodCall -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodCall -> MethodCall
toXRMethodCall

-- | Makes an XML-representation of a method response.
-- FIXME: pretty prints ugly XML
renderResponse :: MethodResponse -> BSL.ByteString
renderResponse :: MethodResponse -> ByteString
renderResponse  = Bool -> MethodResponse -> ByteString
forall a. XmlContent a => Bool -> a -> ByteString
showXml' Bool
False (MethodResponse -> ByteString)
-> (MethodResponse -> MethodResponse)
-> MethodResponse
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodResponse -> MethodResponse
toXRMethodResponse

showXml' :: XmlContent a => Bool -> a -> BSL.ByteString
showXml' :: forall a. XmlContent a => Bool -> a -> ByteString
showXml' Bool
dtd a
x = case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
                   [CElem Element ()
_ ()
_] -> (Document () -> ByteString
forall i. Document i -> ByteString
document (Document () -> ByteString)
-> (a -> Document ()) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
                   [Content ()]
_ -> String -> ByteString
BSL.pack String
""