{-# 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')
| [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
ys [a]
xs = [a]
zs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
ys [a]
zs (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ys) [a]
xs)
| Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
ys [a]
zs [a]
xs'
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 = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err
maybeToM String
_ (Just a
x) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
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) = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
eitherToM String
_ (Right a
x) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
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 = IO (Err m a) -> Err m a
forall a. IO a -> a
unsafePerformIO ((a -> Err m a) -> IO a -> IO (Err m a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Err m a
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a
forall a. a -> IO a
evaluate a
x) IO (Err m a) -> (SomeException -> IO (Err m a)) -> IO (Err m a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO (Err m a)
forall (m :: * -> *) a. Monad m => SomeException -> IO (Err m a)
handleErr)
where handleErr :: Monad m => SomeException -> IO (Err m a)
handleErr :: forall (m :: * -> *) a. Monad m => SomeException -> IO (Err m a)
handleErr = Err m a -> IO (Err m a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Err m a -> IO (Err m a))
-> (SomeException -> Err m a) -> SomeException -> IO (Err m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err m a
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Err m a)
-> (SomeException -> String) -> SomeException -> Err m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show
ioErrorToErr :: IO a -> Err IO a
ioErrorToErr :: forall a. IO a -> Err IO a
ioErrorToErr IO a
x = (IO a -> ExceptT String IO a
forall a. IO a -> Err IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
x ExceptT String IO a
-> (a -> ExceptT String IO a) -> ExceptT String IO a
forall a b.
ExceptT String IO a
-> (a -> ExceptT String IO b) -> ExceptT String IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ExceptT String IO a
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return) ExceptT String IO a
-> (String -> ExceptT String IO a) -> ExceptT String IO a
forall a.
ExceptT String IO a
-> (String -> ExceptT String IO a) -> ExceptT String IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \String
e -> String -> ExceptT String IO a
forall a. String -> ExceptT String IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> String
forall a. Show a => a -> String
show String
e)
handleError :: MonadFail m => (String -> m a) -> Err m a -> m a
handleError :: forall (m :: * -> *) a.
MonadFail m =>
(String -> m a) -> Err m a -> m a
handleError String -> m a
h Err m a
m = do
Right a
x <- Err m a -> m (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Err m a -> (String -> Err m a) -> Err m a
forall a.
ExceptT String m a
-> (String -> ExceptT String m a) -> ExceptT String m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError Err m a
m (m a -> Err m a
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> Err m a) -> (String -> m a) -> String -> Err m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
h))
a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
errorRead :: (MonadFail m, Read a) =>
ReadS a
-> 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] -> a -> Err m a
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
[a]
_ -> String -> Err m a
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
data MethodCall = MethodCall String [Value]
deriving (MethodCall -> MethodCall -> Bool
(MethodCall -> MethodCall -> Bool)
-> (MethodCall -> MethodCall -> Bool) -> Eq MethodCall
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MethodCall -> MethodCall -> Bool
== :: MethodCall -> MethodCall -> Bool
$c/= :: MethodCall -> MethodCall -> Bool
/= :: MethodCall -> MethodCall -> Bool
Eq, Int -> MethodCall -> String -> String
[MethodCall] -> String -> String
MethodCall -> String
(Int -> MethodCall -> String -> String)
-> (MethodCall -> String)
-> ([MethodCall] -> String -> String)
-> Show MethodCall
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MethodCall -> String -> String
showsPrec :: Int -> MethodCall -> String -> String
$cshow :: MethodCall -> String
show :: MethodCall -> String
$cshowList :: [MethodCall] -> String -> String
showList :: [MethodCall] -> String -> String
Show)
data MethodResponse = Return Value
| Fault Int String
deriving (MethodResponse -> MethodResponse -> Bool
(MethodResponse -> MethodResponse -> Bool)
-> (MethodResponse -> MethodResponse -> Bool) -> Eq MethodResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MethodResponse -> MethodResponse -> Bool
== :: MethodResponse -> MethodResponse -> Bool
$c/= :: MethodResponse -> MethodResponse -> Bool
/= :: MethodResponse -> MethodResponse -> Bool
Eq, Int -> MethodResponse -> String -> String
[MethodResponse] -> String -> String
MethodResponse -> String
(Int -> MethodResponse -> String -> String)
-> (MethodResponse -> String)
-> ([MethodResponse] -> String -> String)
-> Show MethodResponse
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MethodResponse -> String -> String
showsPrec :: Int -> MethodResponse -> String -> String
$cshow :: MethodResponse -> String
show :: MethodResponse -> String
$cshowList :: [MethodResponse] -> String -> String
showList :: [MethodResponse] -> String -> String
Show)
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
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, Int -> Value -> String -> String
[Value] -> String -> String
Value -> String
(Int -> Value -> String -> String)
-> (Value -> String) -> ([Value] -> String -> String) -> Show Value
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Value -> String -> String
showsPrec :: Int -> Value -> String -> String
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> String -> String
showList :: [Value] -> String -> String
Show)
data Type =
TInt
| TBool
| TString
| TDouble
| TDateTime
| TBase64
| TStruct
| TArray
| TUnknown
| TNil
deriving (Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
/= :: Type -> Type -> Bool
Eq)
instance Show Type where
show :: Type -> String
show Type
TInt = String
"int"
show Type
TBool = String
"bool"
show Type
TString = String
"string"
show Type
TDouble = String
"double"
show Type
TDateTime = String
"dateTime.iso8601"
show Type
TBase64 = String
"base64"
show Type
TStruct = String
"struct"
show Type
TArray = String
"array"
show Type
TUnknown = String
"unknown"
show Type
TNil = String
"nil"
instance Read Type where
readsPrec :: Int -> ReadS Type
readsPrec Int
_ String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
s) of
(String
"int",String
r) -> [(Type
TInt,String
r)]
(String
"bool",String
r) -> [(Type
TBool,String
r)]
(String
"string",String
r) -> [(Type
TString,String
r)]
(String
"double",String
r) -> [(Type
TDouble,String
r)]
(String
"dateTime.iso8601",String
r) -> [(Type
TDateTime,String
r)]
(String
"base64",String
r) -> [(Type
TBase64,String
r)]
(String
"struct",String
r) -> [(Type
TStruct,String
r)]
(String
"array",String
r) -> [(Type
TArray,String
r)]
(String
"nil",String
r) -> [(Type
TNil,String
r)]
structGetValue :: MonadFail m => String -> Value -> Err m Value
structGetValue :: forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue String
n (ValueStruct [(String, Value)]
t) =
String -> Maybe Value -> ExceptT String m Value
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"Unknown member '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") (String -> [(String, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [(String, Value)]
t)
structGetValue String
_ Value
_ = String -> ExceptT String m Value
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Value is not a struct"
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 [] = String -> ExceptT String m Value
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"Method returned no result"
onlyOneResult [Value
x] = Value -> ExceptT String m Value
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
onlyOneResult [Value]
_ = String -> ExceptT String m Value
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"Method returned more than one result"
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 = (a -> Err m a) -> Err m a
forall a (m :: * -> *). (a -> Err m a) -> Err m a
withType ((a -> Err m a) -> Err m a) -> (a -> Err m a) -> Err m a
forall a b. (a -> b) -> a -> b
$ \a
t ->
String -> Err m a
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Wanted: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show (a -> Type
forall a. XmlRpcType a => a -> Type
getType a
t)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"', got: '"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> Value -> String
forall a. XmlContent a => Bool -> a -> String
showXml Bool
False (Value -> Value
toXRValue Value
v) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") Err m a -> Err m a -> Err m a
forall a. a -> a -> a
`asTypeOf` a -> Err m a
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t
withType :: (a -> Err m a) -> Err m a
withType :: forall a (m :: * -> *). (a -> Err m a) -> Err m a
withType a -> Err m a
f = a -> Err m a
f a
forall a. HasCallStack => a
undefined
simpleFromValue :: (MonadFail m, XmlRpcType a) => (Value -> Maybe a)
-> Value -> Err m a
simpleFromValue :: forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe a
f Value
v =
Err m a -> (a -> Err m a) -> Maybe a -> Err m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Value -> Err m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v) a -> Err m a
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Maybe a
f Value
v)
instance XmlRpcType Value where
toValue :: Value -> Value
toValue = Value -> Value
forall a. a -> a
id
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromValue = Value -> ExceptT String m Value
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT String m Value)
-> (Value -> Value) -> Value -> ExceptT String m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
forall a. a -> a
id
getType :: Value -> Type
getType Value
_ = Type
TUnknown
instance XmlRpcType Int where
toValue :: Int -> Value
toValue = Int -> Value
ValueInt
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Int
fromValue = (Value -> Maybe Int) -> Value -> Err m Int
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe Int
f
where f :: Value -> Maybe Int
f (ValueInt Int
x) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
f Value
_ = Maybe Int
forall a. Maybe a
Nothing
getType :: Int -> Type
getType Int
_ = Type
TInt
instance XmlRpcType Bool where
toValue :: Bool -> Value
toValue = Bool -> Value
ValueBool
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Bool
fromValue = (Value -> Maybe Bool) -> Value -> Err m Bool
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe Bool
f
where f :: Value -> Maybe Bool
f (ValueBool Bool
x) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x
f Value
_ = Maybe Bool
forall a. Maybe a
Nothing
getType :: Bool -> Type
getType Bool
_ = Type
TBool
instance OVERLAPPING_ XmlRpcType String where
toValue :: String -> Value
toValue = String -> Value
ValueString
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m String
fromValue = (Value -> Maybe String) -> Value -> Err m String
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe String
f
where f :: Value -> Maybe String
f (ValueString String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
f (ValueUnwrapped String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
f Value
_ = Maybe String
forall a. Maybe a
Nothing
getType :: String -> Type
getType String
_ = Type
TString
instance XmlRpcType Text where
toValue :: Text -> Value
toValue = String -> Value
ValueString (String -> Value) -> (Text -> String) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Text
fromValue = ((String -> Text)
-> ExceptT String m String -> ExceptT String m Text
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Text
T.pack) (ExceptT String m String -> ExceptT String m Text)
-> (Value -> ExceptT String m String)
-> Value
-> ExceptT String m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ExceptT String m String
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m String
fromValue
getType :: Text -> Type
getType Text
_ = Type
TString
instance XmlRpcType BS.ByteString where
toValue :: ByteString -> Value
toValue = ByteString -> Value
ValueBase64
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m ByteString
fromValue = (Value -> Maybe ByteString) -> Value -> Err m ByteString
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe ByteString
f
where f :: Value -> Maybe ByteString
f (ValueBase64 ByteString
x) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x
f Value
_ = Maybe ByteString
forall a. Maybe a
Nothing
getType :: ByteString -> Type
getType ByteString
_ = Type
TBase64
instance XmlRpcType Double where
toValue :: Double -> Value
toValue = Double -> Value
ValueDouble
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Double
fromValue = (Value -> Maybe Double) -> Value -> Err m Double
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe Double
f
where f :: Value -> Maybe Double
f (ValueDouble Double
x) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x
f Value
_ = Maybe Double
forall a. Maybe a
Nothing
getType :: Double -> Type
getType Double
_ = Type
TDouble
instance XmlRpcType LocalTime where
toValue :: LocalTime -> Value
toValue = LocalTime -> Value
ValueDateTime
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m LocalTime
fromValue = (Value -> Maybe LocalTime) -> Value -> Err m LocalTime
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe LocalTime
f
where f :: Value -> Maybe LocalTime
f (ValueDateTime LocalTime
x) = LocalTime -> Maybe LocalTime
forall a. a -> Maybe a
Just LocalTime
x
f Value
_ = Maybe LocalTime
forall a. Maybe a
Nothing
getType :: LocalTime -> Type
getType LocalTime
_ = Type
TDateTime
instance XmlRpcType CalendarTime where
toValue :: CalendarTime -> Value
toValue = LocalTime -> Value
forall a. XmlRpcType a => a -> Value
toValue (LocalTime -> Value)
-> (CalendarTime -> LocalTime) -> CalendarTime -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalendarTime -> LocalTime
calendarTimeToLocalTime
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m CalendarTime
fromValue = (LocalTime -> CalendarTime)
-> ExceptT String m LocalTime -> ExceptT String m CalendarTime
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LocalTime -> CalendarTime
localTimeToCalendarTime (ExceptT String m LocalTime -> ExceptT String m CalendarTime)
-> (Value -> ExceptT String m LocalTime)
-> Value
-> ExceptT String m CalendarTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ExceptT String m LocalTime
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m LocalTime
fromValue
getType :: CalendarTime -> Type
getType CalendarTime
_ = Type
TDateTime
instance XmlRpcType () where
toValue :: () -> Value
toValue = Value -> () -> Value
forall a b. a -> b -> a
const Value
ValueNil
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m ()
fromValue = (Value -> Maybe ()) -> Value -> Err m ()
forall (m :: * -> *) a.
(MonadFail m, XmlRpcType a) =>
(Value -> Maybe a) -> Value -> Err m a
simpleFromValue Value -> Maybe ()
f
where f :: Value -> Maybe ()
f Value
ValueNil = () -> Maybe ()
forall a. a -> Maybe a
Just ()
f Value
_ = Maybe ()
forall a. Maybe a
Nothing
getType :: () -> Type
getType ()
_ = Type
TNil
instance OVERLAPPABLE_ XmlRpcType a => XmlRpcType [a] where
toValue :: [a] -> Value
toValue = [Value] -> Value
ValueArray ([Value] -> Value) -> ([a] -> [Value]) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
forall a. XmlRpcType a => a -> Value
toValue
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m [a]
fromValue Value
v = case Value
v of
ValueArray [Value]
xs -> (Value -> ExceptT String m a) -> [Value] -> Err m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue [Value]
xs
Value
_ -> Value -> Err m [a]
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v
getType :: [a] -> Type
getType [a]
_ = Type
TArray
instance OVERLAPPING_ XmlRpcType a => XmlRpcType [(String,a)] where
toValue :: [(String, a)] -> Value
toValue [(String, a)]
xs = [(String, Value)] -> Value
ValueStruct [(String
n, a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
v) | (String
n,a
v) <- [(String, a)]
xs]
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m [(String, a)]
fromValue Value
v = case Value
v of
ValueStruct [(String, Value)]
xs -> ((String, Value) -> ExceptT String m (String, a))
-> [(String, Value)] -> Err m [(String, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (String
n,Value
v') -> (a -> (String, a))
-> ExceptT String m a -> ExceptT String m (String, a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) String
n) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
v')) [(String, Value)]
xs
Value
_ -> Value -> Err m [(String, a)]
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v
getType :: [(String, a)] -> Type
getType [(String, a)]
_ = Type
TStruct
instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d,
XmlRpcType e) =>
XmlRpcType (a,b,c,d,e) where
toValue :: (a, b, c, d, e) -> Value
toValue (a
v,b
w,c
x,d
y,e
z) =
[Value] -> Value
ValueArray [a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
v, b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
w, c -> Value
forall a. XmlRpcType a => a -> Value
toValue c
x, d -> Value
forall a. XmlRpcType a => a -> Value
toValue d
y, e -> Value
forall a. XmlRpcType a => a -> Value
toValue e
z]
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (a, b, c, d, e)
fromValue (ValueArray [Value
v,Value
w,Value
x,Value
y,Value
z]) =
(a -> b -> c -> d -> e -> (a, b, c, d, e))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m c
-> ExceptT String m d
-> ExceptT String m e
-> ExceptT String m (a, b, c, d, e)
forall (m :: * -> *) a1 a2 a3 a4 a5 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> a5 -> r)
-> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
liftM5 (,,,,) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
v) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m b
fromValue Value
w) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m c
fromValue Value
x)
(Value -> ExceptT String m d
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m d
fromValue Value
y) (Value -> ExceptT String m e
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m e
fromValue Value
z)
fromValue Value
_ = String -> ExceptT String m (a, b, c, d, e)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expected 5-element tuple!"
getType :: (a, b, c, d, e) -> Type
getType (a, b, c, d, e)
_ = Type
TArray
instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d) =>
XmlRpcType (a,b,c,d) where
toValue :: (a, b, c, d) -> Value
toValue (a
w,b
x,c
y,d
z) = [Value] -> Value
ValueArray [a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
w, b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
x, c -> Value
forall a. XmlRpcType a => a -> Value
toValue c
y, d -> Value
forall a. XmlRpcType a => a -> Value
toValue d
z]
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (a, b, c, d)
fromValue (ValueArray [Value
w,Value
x,Value
y,Value
z]) =
(a -> b -> c -> d -> (a, b, c, d))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m c
-> ExceptT String m d
-> ExceptT String m (a, b, c, d)
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
w) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m b
fromValue Value
x) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m c
fromValue Value
y) (Value -> ExceptT String m d
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m d
fromValue Value
z)
fromValue Value
_ = String -> ExceptT String m (a, b, c, d)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expected 4-element tuple!"
getType :: (a, b, c, d) -> Type
getType (a, b, c, d)
_ = Type
TArray
instance (XmlRpcType a, XmlRpcType b, XmlRpcType c) => XmlRpcType (a,b,c) where
toValue :: (a, b, c) -> Value
toValue (a
x,b
y,c
z) = [Value] -> Value
ValueArray [a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
x, b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
y, c -> Value
forall a. XmlRpcType a => a -> Value
toValue c
z]
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (a, b, c)
fromValue (ValueArray [Value
x,Value
y,Value
z]) =
(a -> b -> c -> (a, b, c))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m c
-> ExceptT String m (a, b, c)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (,,) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
x) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m b
fromValue Value
y) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m c
fromValue Value
z)
fromValue Value
_ = String -> ExceptT String m (a, b, c)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expected 3-element tuple!"
getType :: (a, b, c) -> Type
getType (a, b, c)
_ = Type
TArray
instance (XmlRpcType a, XmlRpcType b) => XmlRpcType (a,b) where
toValue :: (a, b) -> Value
toValue (a
x,b
y) = [Value] -> Value
ValueArray [a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
x, b -> Value
forall a. XmlRpcType a => a -> Value
toValue b
y]
fromValue :: forall (m :: * -> *). MonadFail m => Value -> Err m (a, b)
fromValue (ValueArray [Value
x,Value
y]) = (a -> b -> (a, b))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m (a, b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
x) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m b
fromValue Value
y)
fromValue Value
_ = String -> ExceptT String m (a, b)
forall a. String -> ExceptT String m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expected 2-element tuple."
getType :: (a, b) -> Type
getType (a, b)
_ = Type
TArray
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 = String -> Maybe Value -> ExceptT String m Value
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM (String
"struct member " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found")
(String -> [(String, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Value)]
xs) ExceptT String m Value
-> (Value -> ExceptT String m a) -> ExceptT String m a
forall a b.
ExceptT String m a
-> (a -> ExceptT String m b) -> ExceptT String m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue
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 String -> [(String, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Value)]
xs of
Maybe Value
Nothing -> Maybe a -> Err m (Maybe a)
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just Value
v -> (a -> Maybe a) -> ExceptT String m a -> Err m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just (Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m a
fromValue Value
v)
toXRValue :: Value -> XR.Value
toXRValue :: Value -> Value
toXRValue (ValueInt Int
x) = [Value_] -> Value
XR.Value [AInt -> Value_
XR.Value_AInt (String -> AInt
XR.AInt (Int -> String
showInt Int
x))]
toXRValue (ValueBool Bool
b) = [Value_] -> Value
XR.Value [Boolean -> Value_
XR.Value_Boolean (String -> Boolean
XR.Boolean (Bool -> String
showBool Bool
b))]
toXRValue (ValueString String
s) = [Value_] -> Value
XR.Value [AString -> Value_
XR.Value_AString (String -> AString
XR.AString (String -> String
showString String
s))]
toXRValue (ValueUnwrapped String
s) = [Value_] -> Value
XR.Value [String -> Value_
XR.Value_Str String
s]
toXRValue (ValueDouble Double
d) = [Value_] -> Value
XR.Value [ADouble -> Value_
XR.Value_ADouble (String -> ADouble
XR.ADouble (Double -> String
showDouble Double
d))]
toXRValue (ValueDateTime LocalTime
t) =
[Value_] -> Value
XR.Value [ DateTime_iso8601 -> Value_
XR.Value_DateTime_iso8601 (String -> DateTime_iso8601
XR.DateTime_iso8601 (LocalTime -> String
showDateTime LocalTime
t))]
toXRValue (ValueBase64 ByteString
s) = [Value_] -> Value
XR.Value [Base64 -> Value_
XR.Value_Base64 (String -> Base64
XR.Base64 (ByteString -> String
showBase64 ByteString
s))]
toXRValue (ValueStruct [(String, Value)]
xs) = [Value_] -> Value
XR.Value [Struct -> Value_
XR.Value_Struct ([Member] -> Struct
XR.Struct (((String, Value) -> Member) -> [(String, Value)] -> [Member]
forall a b. (a -> b) -> [a] -> [b]
map (String, Value) -> Member
toXRMember [(String, Value)]
xs))]
toXRValue (ValueArray [Value]
xs) =
[Value_] -> Value
XR.Value [Array -> Value_
XR.Value_Array (Data -> Array
XR.Array ([Value] -> Data
XR.Data ((Value -> Value) -> [Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Value
toXRValue [Value]
xs)))]
toXRValue Value
ValueNil = [Value_] -> Value
XR.Value [Nil -> Value_
XR.Value_Nil (() -> Nil
XR.Nil ())]
showInt :: Int -> String
showInt :: Int -> String
showInt = Int -> String
forall a. Show a => a -> String
show
showBool :: Bool -> String
showBool :: Bool -> String
showBool Bool
b = if Bool
b then String
"1" else String
"0"
showString :: String -> String
showString :: String -> String
showString = String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
">" String
">" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"<" String
"<" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&" String
"&"
showDouble :: Double -> String
showDouble :: Double -> String
showDouble Double
d = Maybe Int -> Double -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showFFloat Maybe Int
forall a. Maybe a
Nothing Double
d String
""
showDateTime :: LocalTime -> String
showDateTime :: LocalTime -> String
showDateTime LocalTime
t = TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
xmlRpcDateFormat LocalTime
t
showBase64 :: BS.ByteString -> String
showBase64 :: ByteString -> String
showBase64 = ByteString -> String
BS.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode
toXRMethodCall :: MethodCall -> XR.MethodCall
toXRMethodCall :: MethodCall -> MethodCall
toXRMethodCall (MethodCall String
name [Value]
vs) =
MethodName -> Maybe Params -> MethodCall
XR.MethodCall (String -> MethodName
XR.MethodName String
name) (Params -> Maybe Params
forall a. a -> Maybe a
Just ([Value] -> Params
toXRParams [Value]
vs))
toXRMethodResponse :: MethodResponse -> XR.MethodResponse
toXRMethodResponse :: MethodResponse -> MethodResponse
toXRMethodResponse (Return Value
val) = Params -> MethodResponse
XR.MethodResponseParams ([Value] -> Params
toXRParams [Value
val])
toXRMethodResponse (Fault Int
code String
str) =
Fault -> MethodResponse
XR.MethodResponseFault (Value -> Fault
XR.Fault (Value -> Value
toXRValue (Int -> String -> Value
faultStruct Int
code String
str)))
toXRParams :: [Value] -> XR.Params
toXRParams :: [Value] -> Params
toXRParams [Value]
vs = [Param] -> Params
XR.Params ((Value -> Param) -> [Value] -> [Param]
forall a b. (a -> b) -> [a] -> [b]
map (Value -> Param
XR.Param (Value -> Param) -> (Value -> Value) -> Value -> Param
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
toXRValue) [Value]
vs)
toXRMember :: (String, Value) -> XR.Member
toXRMember :: (String, Value) -> Member
toXRMember (String
n, Value
v) = Name -> Value -> Member
XR.Member (String -> Name
XR.Name String
n) (Value -> Value
toXRValue Value
v)
fromXRValue :: MonadFail m => XR.Value -> Err m Value
fromXRValue :: forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue (XR.Value [Value_]
vs)
= case ((Value_ -> Bool) -> [Value_] -> [Value_]
forall a. (a -> Bool) -> [a] -> [a]
filter Value_ -> Bool
notstr [Value_]
vs) of
[] -> ([String] -> Value) -> ExceptT String m [String] -> Err m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> Value
ValueUnwrapped (String -> Value) -> ([String] -> String) -> [String] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ((Value_ -> ExceptT String m String)
-> [Value_] -> ExceptT String m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> ExceptT String m String
forall (m :: * -> *). Monad m => String -> Err m String
readString (String -> ExceptT String m String)
-> (Value_ -> String) -> Value_ -> ExceptT String m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value_ -> String
unstr) [Value_]
vs)
(Value_
v:[Value_]
_) -> Value_ -> Err m Value
forall {m :: * -> *}.
MonadFail m =>
Value_ -> ExceptT String m Value
f Value_
v
where
notstr :: Value_ -> Bool
notstr (XR.Value_Str String
_) = Bool
False
notstr Value_
_ = Bool
True
unstr :: Value_ -> String
unstr (XR.Value_Str String
x) = String
x
f :: Value_ -> ExceptT String m Value
f (XR.Value_I4 (XR.I4 String
x)) = (Int -> Value) -> ExceptT String m Int -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (String -> ExceptT String m Int
forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
f (XR.Value_I8 (XR.I8 String
x)) = (Int -> Value) -> ExceptT String m Int -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (String -> ExceptT String m Int
forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
f (XR.Value_AInt (XR.AInt String
x)) = (Int -> Value) -> ExceptT String m Int -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> Value
ValueInt (String -> ExceptT String m Int
forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
x)
f (XR.Value_Boolean (XR.Boolean String
x)) = (Bool -> Value) -> ExceptT String m Bool -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Value
ValueBool (String -> ExceptT String m Bool
forall (m :: * -> *). MonadFail m => String -> Err m Bool
readBool String
x)
f (XR.Value_ADouble (XR.ADouble String
x)) = (Double -> Value)
-> ExceptT String m Double -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Double -> Value
ValueDouble (String -> ExceptT String m Double
forall (m :: * -> *). MonadFail m => String -> Err m Double
readDouble String
x)
f (XR.Value_AString (XR.AString String
x)) = (String -> Value)
-> ExceptT String m String -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Value
ValueString (String -> ExceptT String m String
forall (m :: * -> *). Monad m => String -> Err m String
readString String
x)
f (XR.Value_DateTime_iso8601 (XR.DateTime_iso8601 String
x)) =
(LocalTime -> Value)
-> ExceptT String m LocalTime -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LocalTime -> Value
ValueDateTime (String -> ExceptT String m LocalTime
forall (m :: * -> *). MonadFail m => String -> Err m LocalTime
readDateTime String
x)
f (XR.Value_Base64 (XR.Base64 String
x)) = (ByteString -> Value)
-> ExceptT String m ByteString -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> Value
ValueBase64 (String -> ExceptT String m ByteString
forall (m :: * -> *). Monad m => String -> Err m ByteString
readBase64 String
x)
f (XR.Value_Struct (XR.Struct [Member]
ms)) =
([(String, Value)] -> Value)
-> ExceptT String m [(String, Value)] -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(String, Value)] -> Value
ValueStruct ((Member -> ExceptT String m (String, Value))
-> [Member] -> ExceptT String m [(String, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Member -> ExceptT String m (String, Value)
forall (m :: * -> *).
MonadFail m =>
Member -> Err m (String, Value)
fromXRMember [Member]
ms)
f (XR.Value_Array (XR.Array (XR.Data [Value]
xs))) =
([Value] -> Value)
-> ExceptT String m [Value] -> ExceptT String m Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Value] -> Value
ValueArray ((Value -> ExceptT String m Value)
-> [Value] -> ExceptT String m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue [Value]
xs)
f (XR.Value_Nil (XR.Nil ()
x)) = Value -> ExceptT String m Value
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
ValueNil
fromXRMember :: MonadFail m => XR.Member -> Err m (String,Value)
fromXRMember :: forall (m :: * -> *).
MonadFail m =>
Member -> Err m (String, Value)
fromXRMember (XR.Member (XR.Name String
n) Value
xv) = (Value -> (String, Value))
-> ExceptT String m Value -> ExceptT String m (String, Value)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\Value
v -> (String
n,Value
v)) (Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue Value
xv)
readInt :: MonadFail m => String -> Err m Int
readInt :: forall (m :: * -> *). MonadFail m => String -> Err m Int
readInt String
s = ReadS Int -> String -> String -> Err m Int
forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead ReadS Int
forall a. Read a => ReadS a
reads String
"Error parsing integer" String
s
readBool :: MonadFail m => String -> Err m Bool
readBool :: forall (m :: * -> *). MonadFail m => String -> Err m Bool
readBool String
s = ReadS Bool -> String -> String -> Err m Bool
forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead ReadS Bool
readsBool String
"Error parsing boolean" String
s
where readsBool :: ReadS Bool
readsBool String
"true" = [(Bool
True,String
"")]
readsBool String
"false" = [(Bool
False,String
"")]
readsBool String
"1" = [(Bool
True,String
"")]
readsBool String
"0" = [(Bool
False,String
"")]
readsBool String
_ = []
readString :: Monad m => String -> Err m String
readString :: forall (m :: * -> *). Monad m => String -> Err m String
readString = String -> ExceptT String m String
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ExceptT String m String)
-> (String -> String) -> String -> ExceptT String m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"&" String
"&" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"<" String
"<"
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
">" String
">"
readDouble :: MonadFail m => String -> Err m Double
readDouble :: forall (m :: * -> *). MonadFail m => String -> Err m Double
readDouble String
s = ReadS Double -> String -> String -> Err m Double
forall (m :: * -> *) a.
(MonadFail m, Read a) =>
ReadS a -> String -> String -> Err m a
errorRead ReadS Double
forall a. Read a => ReadS a
reads String
"Error parsing double" String
s
readDateTime :: MonadFail m => String -> Err m LocalTime
readDateTime :: forall (m :: * -> *). MonadFail m => String -> Err m LocalTime
readDateTime String
dt =
Err m LocalTime
-> (LocalTime -> Err m LocalTime)
-> Maybe LocalTime
-> Err m LocalTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(String -> Err m LocalTime
forall a. String -> ExceptT String m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> Err m LocalTime) -> String -> Err m LocalTime
forall a b. (a -> b) -> a -> b
$ String
"Error parsing dateTime '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
LocalTime -> Err m LocalTime
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return
(Bool -> TimeLocale -> String -> String -> Maybe LocalTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
xmlRpcDateFormat String
dt)
localTimeToCalendarTime :: LocalTime -> CalendarTime
localTimeToCalendarTime :: LocalTime -> CalendarTime
localTimeToCalendarTime LocalTime
l =
let (Year
y,Int
mo,Int
d) = Day -> (Year, Int, Int)
toGregorian (LocalTime -> Day
localDay LocalTime
l)
TimeOfDay { todHour :: TimeOfDay -> Int
todHour = Int
h, todMin :: TimeOfDay -> Int
todMin = Int
mi, todSec :: TimeOfDay -> Pico
todSec = Pico
s } = LocalTime -> TimeOfDay
localTimeOfDay LocalTime
l
(Year
_,Int
_,Int
wd) = Day -> (Year, Int, Int)
toWeekDate (LocalTime -> Day
localDay LocalTime
l)
(Year
_,Int
yd) = Day -> (Year, Int)
toOrdinalDate (LocalTime -> Day
localDay LocalTime
l)
in CalendarTime {
ctYear :: Int
ctYear = Year -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
y,
ctMonth :: Month
ctMonth = Int -> Month
forall a. Enum a => Int -> a
toEnum (Int
moInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1),
ctDay :: Int
ctDay = Int
d,
ctHour :: Int
ctHour = Int
h,
ctMin :: Int
ctMin = Int
mi,
ctSec :: Int
ctSec = Pico -> Int
forall b. Integral b => Pico -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Pico
s,
ctPicosec :: Year
ctPicosec = Year
0,
ctWDay :: Day
ctWDay = Int -> Day
forall a. Enum a => Int -> a
toEnum (Int
wd Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7),
ctYDay :: Int
ctYDay = Int
yd,
ctTZName :: String
ctTZName = String
"UTC",
ctTZ :: Int
ctTZ = Int
0,
ctIsDST :: Bool
ctIsDST = Bool
False
}
calendarTimeToLocalTime :: CalendarTime -> LocalTime
calendarTimeToLocalTime :: CalendarTime -> LocalTime
calendarTimeToLocalTime CalendarTime
ct =
let (Int
y,Month
mo,Int
d) = (CalendarTime -> Int
ctYear CalendarTime
ct, CalendarTime -> Month
ctMonth CalendarTime
ct, CalendarTime -> Int
ctDay CalendarTime
ct)
(Int
h,Int
mi,Int
s) = (CalendarTime -> Int
ctHour CalendarTime
ct, CalendarTime -> Int
ctMin CalendarTime
ct, CalendarTime -> Int
ctSec CalendarTime
ct)
in LocalTime {
localDay :: Day
localDay = Year -> Int -> Int -> Day
fromGregorian (Int -> Year
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y) (Month -> Int
forall a. Enum a => a -> Int
fromEnum Month
mo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
d,
localTimeOfDay :: TimeOfDay
localTimeOfDay = TimeOfDay { todHour :: Int
todHour = Int
h, todMin :: Int
todMin = Int
mi, todSec :: Pico
todSec = Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s }
}
readBase64 :: Monad m => String -> Err m BS.ByteString
readBase64 :: forall (m :: * -> *). Monad m => String -> Err m ByteString
readBase64 = ByteString -> ExceptT String m ByteString
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ExceptT String m ByteString)
-> (String -> ByteString) -> String -> ExceptT String m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.decode (ByteString -> ByteString)
-> (String -> ByteString) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack
fromXRParams :: MonadFail m => XR.Params -> Err m [Value]
fromXRParams :: forall (m :: * -> *). MonadFail m => Params -> Err m [Value]
fromXRParams (XR.Params [Param]
xps) = (Param -> ExceptT String m Value)
-> [Param] -> ExceptT String m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(XR.Param Value
v) -> Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue Value
v) [Param]
xps
fromXRMethodCall :: MonadFail m => XR.MethodCall -> Err m MethodCall
fromXRMethodCall :: forall (m :: * -> *). MonadFail m => MethodCall -> Err m MethodCall
fromXRMethodCall (XR.MethodCall (XR.MethodName String
name) Maybe Params
params) =
([Value] -> MethodCall)
-> ExceptT String m [Value] -> ExceptT String m MethodCall
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> [Value] -> MethodCall
MethodCall String
name) (Params -> ExceptT String m [Value]
forall (m :: * -> *). MonadFail m => Params -> Err m [Value]
fromXRParams (Params -> Maybe Params -> Params
forall a. a -> Maybe a -> a
fromMaybe ([Param] -> Params
XR.Params []) Maybe Params
params))
fromXRMethodResponse :: MonadFail m => XR.MethodResponse -> Err m MethodResponse
fromXRMethodResponse :: forall (m :: * -> *).
MonadFail m =>
MethodResponse -> Err m MethodResponse
fromXRMethodResponse (XR.MethodResponseParams Params
xps) =
(Value -> MethodResponse)
-> ExceptT String m Value -> ExceptT String m MethodResponse
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Value -> MethodResponse
Return (Params -> Err m [Value]
forall (m :: * -> *). MonadFail m => Params -> Err m [Value]
fromXRParams Params
xps Err m [Value]
-> ([Value] -> ExceptT String m Value) -> ExceptT String m Value
forall a b.
ExceptT String m a
-> (a -> ExceptT String m b) -> ExceptT String m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Value] -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => [Value] -> Err m Value
onlyOneResult)
fromXRMethodResponse (XR.MethodResponseFault (XR.Fault Value
v)) =
do
Value
struct <- Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue Value
v
Value
vcode <- String -> Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue String
"faultCode" Value
struct
Int
code <- Value -> Err m Int
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m Int
fromValue Value
vcode
Value
vstr <- String -> Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue String
"faultString" Value
struct
String
str <- Value -> Err m String
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
forall (m :: * -> *). MonadFail m => Value -> Err m String
fromValue Value
vstr
MethodResponse -> ExceptT String m MethodResponse
forall a. a -> ExceptT String m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> MethodResponse
Fault Int
code String
str)
parseCall :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodCall
parseCall :: forall e (m :: * -> *).
(Show e, MonadError e m, MonadFail m) =>
String -> Err m MethodCall
parseCall String
c =
do
Either String MethodCall
mxc <- Either String MethodCall -> Err m (Either String MethodCall)
forall e (m :: * -> *) a. (Show e, MonadError e m) => a -> Err m a
errorToErr (String -> Either String MethodCall
forall a. XmlContent a => String -> Either String a
readXml String
c)
MethodCall
xc <- String -> Either String MethodCall -> ExceptT String m MethodCall
forall (m :: * -> *) a.
MonadFail m =>
String -> Either String a -> m a
eitherToM String
"Error parsing method call" Either String MethodCall
mxc
MethodCall -> Err m MethodCall
forall (m :: * -> *). MonadFail m => MethodCall -> Err m MethodCall
fromXRMethodCall MethodCall
xc
parseResponse :: (Show e, MonadError e m, MonadFail m) => String -> Err m MethodResponse
parseResponse :: forall e (m :: * -> *).
(Show e, MonadError e m, MonadFail m) =>
String -> Err m MethodResponse
parseResponse String
c =
do
Either String MethodResponse
mxr <- Either String MethodResponse
-> Err m (Either String MethodResponse)
forall e (m :: * -> *) a. (Show e, MonadError e m) => a -> Err m a
errorToErr (String -> Either String MethodResponse
forall a. XmlContent a => String -> Either String a
readXml String
c)
MethodResponse
xr <- String
-> Either String MethodResponse -> ExceptT String m MethodResponse
forall (m :: * -> *) a.
MonadFail m =>
String -> Either String a -> m a
eitherToM String
"Error parsing method response" Either String MethodResponse
mxr
MethodResponse -> Err m MethodResponse
forall (m :: * -> *).
MonadFail m =>
MethodResponse -> Err m MethodResponse
fromXRMethodResponse MethodResponse
xr
renderCall :: MethodCall -> BSL.ByteString
renderCall :: MethodCall -> ByteString
renderCall = Bool -> MethodCall -> ByteString
forall a. XmlContent a => Bool -> a -> ByteString
showXml' Bool
False (MethodCall -> ByteString)
-> (MethodCall -> MethodCall) -> MethodCall -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodCall -> MethodCall
toXRMethodCall
renderResponse :: MethodResponse -> BSL.ByteString
renderResponse :: MethodResponse -> ByteString
renderResponse = Bool -> MethodResponse -> ByteString
forall a. XmlContent a => Bool -> a -> ByteString
showXml' Bool
False (MethodResponse -> ByteString)
-> (MethodResponse -> MethodResponse)
-> MethodResponse
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MethodResponse -> MethodResponse
toXRMethodResponse
showXml' :: XmlContent a => Bool -> a -> BSL.ByteString
showXml' :: forall a. XmlContent a => Bool -> a -> ByteString
showXml' Bool
dtd a
x = case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
[CElem Element ()
_ ()
_] -> (Document () -> ByteString
forall i. Document i -> ByteString
document (Document () -> ByteString)
-> (a -> Document ()) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
[Content ()]
_ -> String -> ByteString
BSL.pack String
""