{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif
module Network.XmlRpc.Internals (
MethodCall(..), MethodResponse(..),
Value(..), Type(..), XmlRpcType(..),
parseResponse, parseCall, getField, getFieldMaybe,
renderCall, renderResponse,
toXRValue, fromXRValue,
toXRMethodCall, fromXRMethodCall,
toXRMethodResponse, fromXRMethodResponse,
toXRParams, fromXRParams,
toXRMember, fromXRMember,
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
replace :: Eq a =>
[a]
-> [a]
-> [a]
-> [a]
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'
maybeToM :: MonadFail m =>
String
-> Maybe a
-> m a
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
eitherToM :: MonadFail m
=> String
-> Either String a
-> m a
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
xmlRpcDateFormat :: String
xmlRpcDateFormat :: String
xmlRpcDateFormat = String
"%Y%m%dT%H:%M:%S"
type Err m a = ExceptT String m a
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
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)
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
-> String
-> String
-> 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
"'")
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)
data MethodResponse = Return Value
| Fault Int String
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)
data Value =
ValueInt Int
| ValueBool Bool
| ValueString String
| ValueUnwrapped String
| ValueDouble Double
| ValueDateTime LocalTime
| ValueBase64 BS.ByteString
| ValueStruct [(String,Value)]
| ValueArray [Value]
| ValueNil
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)
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)]
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"
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)]
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"
class XmlRpcType a where
toValue :: a -> Value
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
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)
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
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
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
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
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
getField :: (MonadFail m, XmlRpcType a) =>
String
-> [(String,Value)]
-> 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
getFieldMaybe :: (MonadFail m, XmlRpcType a) =>
String
-> [(String,Value)]
-> 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)
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"
showString :: String -> String
showString :: ShowS
showString = forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
">" String
">" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"<" String
"<" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&" String
"&"
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
""
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)
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)
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
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
_ = []
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
"&" String
"&" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"<" String
"<"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
">" String
">"
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
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 }
}
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)
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
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
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
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
""