{-# 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')
    | forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
ys [a]
xs = [a]
zs forall a. [a] -> [a] -> [a]
++ forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
ys [a]
zs (forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys) [a]
xs)
    | Bool
otherwise = a
x forall 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 = forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err
maybeToM String
_ (Just a
x) = 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)  = forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
err forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
s)
eitherToM   String
_ (Right a
x) = 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 = forall a. IO a -> a
unsafePerformIO (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> IO a
evaluate a
x) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \String
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (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 <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError Err m a
m (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
h))
                  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] -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
                          [a]
_   -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
err forall a. [a] -> [a] -> [a]
++ String
": '" forall a. [a] -> [a] -> [a]
++ String
s 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodCall -> MethodCall -> Bool
$c/= :: MethodCall -> MethodCall -> Bool
== :: MethodCall -> MethodCall -> Bool
$c== :: MethodCall -> MethodCall -> Bool
Eq, Int -> MethodCall -> ShowS
[MethodCall] -> ShowS
MethodCall -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MethodCall] -> ShowS
$cshowList :: [MethodCall] -> ShowS
show :: MethodCall -> String
$cshow :: MethodCall -> String
showsPrec :: Int -> MethodCall -> ShowS
$cshowsPrec :: Int -> MethodCall -> ShowS
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MethodResponse -> MethodResponse -> Bool
$c/= :: MethodResponse -> MethodResponse -> Bool
== :: MethodResponse -> MethodResponse -> Bool
$c== :: MethodResponse -> MethodResponse -> Bool
Eq, Int -> MethodResponse -> ShowS
[MethodResponse] -> ShowS
MethodResponse -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MethodResponse] -> ShowS
$cshowList :: [MethodResponse] -> ShowS
show :: MethodResponse -> String
$cshow :: MethodResponse -> String
showsPrec :: Int -> MethodResponse -> ShowS
$cshowsPrec :: Int -> MethodResponse -> ShowS
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: 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 forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (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) =
    forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown member '" forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
"'") (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [(String, Value)]
t)
structGetValue String
_ Value
_ = 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 [] = forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"Method returned no result"
onlyOneResult [Value
x] = forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
onlyOneResult [Value]
_ = 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 = forall a (m :: * -> *). (a -> Err m a) -> Err m a
withType forall a b. (a -> b) -> a -> b
$ \a
t ->
       forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Wanted: "
             forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. XmlRpcType a => a -> Type
getType a
t)
             forall a. [a] -> [a] -> [a]
++ String
"', got: '"
             forall a. [a] -> [a] -> [a]
++ forall a. XmlContent a => Bool -> a -> String
showXml Bool
False (Value -> Value
toXRValue Value
v) forall a. [a] -> [a] -> [a]
++ String
"'") forall a. a -> a -> a
`asTypeOf` 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 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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v) 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 = forall a. a -> a
id
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromValue = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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) = forall a. a -> Maybe a
Just Int
x
              f Value
_ = 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 = 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) = forall a. a -> Maybe a
Just Bool
x
              f Value
_ = 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 = 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) = forall a. a -> Maybe a
Just String
x
              f (ValueUnwrapped String
x) = forall a. a -> Maybe a
Just String
x
              f Value
_ = forall a. Maybe a
Nothing
    getType :: String -> Type
getType String
_ = Type
TString

instance XmlRpcType Text where
    toValue :: Text -> Value
toValue = String -> Value
ValueString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Text
fromValue = (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Text
T.pack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
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 = 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) = forall a. a -> Maybe a
Just ByteString
x
              f Value
_ = 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 = 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) = forall a. a -> Maybe a
Just Double
x
              f Value
_ = 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 = 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) = forall a. a -> Maybe a
Just LocalTime
x
              f Value
_ = forall a. Maybe a
Nothing
    getType :: LocalTime -> Type
getType LocalTime
_ = Type
TDateTime

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

instance XmlRpcType () where
    toValue :: () -> Value
toValue = forall a b. a -> b -> a
const Value
ValueNil
    fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m ()
fromValue = 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 = forall a. a -> Maybe a
Just ()
              f Value
_ = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue [Value]
xs
                         Value
_ -> 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, 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 -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (String
n,Value
v') -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) String
n) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
v')) [(String, Value)]
xs
                  Value
_ -> 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 [forall a. XmlRpcType a => a -> Value
toValue a
v, forall a. XmlRpcType a => a -> Value
toValue b
w, forall a. XmlRpcType a => a -> Value
toValue c
x, forall a. XmlRpcType a => a -> Value
toValue d
y, 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]) =
        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 (,,,,) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
v) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
w) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
x)
                      (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
y) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
z)
    fromValue Value
_ = 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 [forall a. XmlRpcType a => a -> Value
toValue a
w, forall a. XmlRpcType a => a -> Value
toValue b
x, forall a. XmlRpcType a => a -> Value
toValue c
y, 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]) =
        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 (,,,) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
w) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
x) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
y) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
z)
    fromValue Value
_ = 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 [forall a. XmlRpcType a => a -> Value
toValue a
x, forall a. XmlRpcType a => a -> Value
toValue b
y, 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]) =
        forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (,,) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
x) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
y) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
z)
    fromValue Value
_ = 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 [forall a. XmlRpcType a => a -> Value
toValue a
x, 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]) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
x) (forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
y)
    fromValue Value
_ = 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 = forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"struct member " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
x forall a. [a] -> [a] -> [a]
++ String
" not found")
                (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Value)]
xs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *).
(XmlRpcType a, 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 forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Value)]
xs of
                                      Maybe Value
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                                      Just Value
v -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just (forall a (m :: * -> *).
(XmlRpcType a, 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 (ShowS
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 (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 (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 = 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 :: ShowS
showString = forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
">" String
"&gt;" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"<" String
"&lt;" forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat 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 = 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 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) (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 (forall a b. (a -> b) -> [a] -> [b]
map (Value -> Param
XR.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 (forall a. (a -> Bool) -> [a] -> [a]
filter Value_ -> Bool
notstr [Value_]
vs) of
       []     -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM  (String -> Value
ValueUnwrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). Monad m => String -> Err m String
readString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value_ -> String
unstr) [Value_]
vs)
       (Value_
v:[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)) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
  f (XR.Value_I8 (XR.I8 String
x)) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
  f (XR.Value_AInt (XR.AInt String
x)) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
  f (XR.Value_Boolean (XR.Boolean String
x)) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Value
ValueBool (forall (m :: * -> *). MonadFail m => String -> Err m Bool
readBool String
x)
  f (XR.Value_ADouble (XR.ADouble String
x)) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Double -> Value
ValueDouble (forall (m :: * -> *). MonadFail m => String -> Err m Double
readDouble String
x)
  f (XR.Value_AString (XR.AString String
x)) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Value
ValueString (forall (m :: * -> *). Monad m => String -> Err m String
readString String
x)
  f (XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 String
x)) =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LocalTime -> Value
ValueDateTime (forall (m :: * -> *). MonadFail m => String -> Err m LocalTime
readDateTime String
x)
  f (XR.Value_Base64 (XR.Base64 String
x)) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> Value
ValueBase64 (forall (m :: * -> *). Monad m => String -> Err m ByteString
readBase64 String
x)
  f (XR.Value_Struct (XR.Struct [Member]
ms)) =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(String, Value)] -> Value
ValueStruct (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadFail m =>
Member -> Err m (String, Value)
fromXRMember [Member]
ms)
  f (XR.Value_Array (XR.Array (XR.Data [Value]
xs))) =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Value] -> Value
ValueArray (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue [Value]
xs)
  f (XR.Value_Nil (XR.Nil ()
x)) = 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) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\Value
v -> (String
n,Value
v)) (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 = forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead 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 = forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead String -> [(Bool, String)]
readsBool String
"Error parsing boolean" String
s
    where readsBool :: String -> [(Bool, String)]
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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&amp;" String
"&" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&lt;" String
"<"
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead 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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"Error parsing dateTime '" forall a. [a] -> [a] -> [a]
++ String
dt forall a. [a] -> [a] -> [a]
++ String
"'")
        forall (m :: * -> *) a. Monad m => a -> m a
return
        (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    = forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
y,
                      ctMonth :: Month
ctMonth   = forall a. Enum a => Int -> a
toEnum (Int
moforall 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     = forall a b. (RealFrac a, Integral b) => a -> b
truncate Pico
s,
                      ctPicosec :: Year
ctPicosec = Year
0,
                      ctWDay :: Day
ctWDay    = forall a. Enum a => Int -> a
toEnum (Int
wd 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) (forall a. Enum a => a -> Int
fromEnum Month
mo 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 = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.decode 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) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(XR.Param Value
v) -> 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) =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> [Value] -> MethodCall
MethodCall String
name) (forall (m :: * -> *). MonadFail m => Params -> Err m [Value]
fromXRParams (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) =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Value -> MethodResponse
Return (forall (m :: * -> *). MonadFail m => Params -> Err m [Value]
fromXRParams Params
xps forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => [Value] -> Err m Value
onlyOneResult)
fromXRMethodResponse (XR.MethodResponseFault (XR.Fault Value
v)) =
    do
    Value
struct <- forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue Value
v
    Value
vcode <- forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue String
"faultCode" Value
struct
    Int
code <- forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
vcode
    Value
vstr <- forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue String
"faultString" Value
struct
    String
str <- forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
vstr
    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 <- forall e (m :: * -> *) a. (Show e, MonadError e m) => a -> Err m a
errorToErr (forall a. XmlContent a => String -> Either String a
readXml String
c)
    MethodCall
xc <- forall (m :: * -> *) a.
MonadFail m =>
String -> Either String a -> m a
eitherToM String
"Error parsing method call" Either String MethodCall
mxc
    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 <- forall e (m :: * -> *) a. (Show e, MonadError e m) => a -> Err m a
errorToErr (forall a. XmlContent a => String -> Either String a
readXml String
c)
    MethodResponse
xr <- forall (m :: * -> *) a.
MonadFail m =>
String -> Either String a -> m a
eitherToM String
"Error parsing method response" Either String MethodResponse
mxr
    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 = forall a. XmlContent a => Bool -> a -> ByteString
showXml' Bool
False 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  = forall a. XmlContent a => Bool -> a -> ByteString
showXml' Bool
False 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 forall a. XmlContent a => a -> [Content ()]
toContents a
x of
                   [CElem Element ()
_ ()
_] -> (forall i. Document i -> ByteString
document forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
                   [Content ()]
_ -> String -> ByteString
BSL.pack String
""