{-# 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
import qualified Control.Monad.Fail as Fail
import Control.Monad.Fail (MonadFail)
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 :: [a] -> [a] -> [a] -> [a]
replace [] _ xs :: [a]
xs = [a]
xs
replace _ _ [] = []
replace ys :: [a]
ys zs :: [a]
zs xs :: [a]
xs@(x :: a
x:xs' :: [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 (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 :: String -> Maybe a -> m a
maybeToM err :: String
err Nothing = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err
maybeToM _ (Just x :: a
x) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
eitherToM :: MonadFail m
=> String
-> Either String a
-> m a
eitherToM :: String -> Either String a -> m a
eitherToM err :: String
err (Left s :: String
s) = 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
forall a. [a] -> [a] -> [a]
++ String
s)
eitherToM _ (Right x :: a
x) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
xmlRpcDateFormat :: String
xmlRpcDateFormat :: String
xmlRpcDateFormat = "%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 :: a -> Err m a
errorToErr x :: 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 (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 :: SomeException -> IO (Err m a)
handleErr = Err m a -> IO (Err m 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 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 :: IO a -> Err IO a
ioErrorToErr x :: IO a
x = (IO a -> Err IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
x Err IO a -> (a -> Err IO a) -> Err IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Err IO a
forall (m :: * -> *) a. Monad m => a -> m a
return) Err IO a -> (String -> Err IO a) -> Err IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \e :: String
e -> String -> Err 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 :: (String -> m a) -> Err m a -> m a
handleError h :: String -> m a
h m :: Err m a
m = do
Right x :: 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 e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError Err m a
m (m a -> Err 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 (m :: * -> *) a. Monad m => a -> m a
return a
x
errorRead :: (MonadFail m, Read a) =>
ReadS a
-> String
-> String
-> Err m a
errorRead :: ReadS a -> String -> String -> Err m a
errorRead r :: ReadS a
r err :: String
err s :: String
s = case [a
x | (x :: a
x,t :: String
t) <- ReadS a
r String
s, ("","") <- ReadS String
lex String
t] of
[x :: a
x] -> a -> Err m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
_ -> String -> Err 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
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'")
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
/= :: MethodCall -> MethodCall -> Bool
$c/= :: MethodCall -> MethodCall -> Bool
== :: MethodCall -> MethodCall -> Bool
$c== :: 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
showList :: [MethodCall] -> String -> String
$cshowList :: [MethodCall] -> String -> String
show :: MethodCall -> String
$cshow :: MethodCall -> String
showsPrec :: Int -> MethodCall -> String -> String
$cshowsPrec :: Int -> 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
/= :: MethodResponse -> MethodResponse -> Bool
$c/= :: MethodResponse -> MethodResponse -> Bool
== :: MethodResponse -> MethodResponse -> Bool
$c== :: 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
showList :: [MethodResponse] -> String -> String
$cshowList :: [MethodResponse] -> String -> String
show :: MethodResponse -> String
$cshow :: MethodResponse -> String
showsPrec :: Int -> MethodResponse -> String -> String
$cshowsPrec :: Int -> 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
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: 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
showList :: [Value] -> String -> String
$cshowList :: [Value] -> String -> String
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> String -> String
$cshowsPrec :: Int -> 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
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq)
instance Show Type where
show :: Type -> String
show TInt = "int"
show TBool = "bool"
show TString = "string"
show TDouble = "double"
show TDateTime = "dateTime.iso8601"
show TBase64 = "base64"
show TStruct = "struct"
show TArray = "array"
show TUnknown = "unknown"
show TNil = "nil"
instance Read Type where
readsPrec :: Int -> ReadS Type
readsPrec _ s :: 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
("int",r :: String
r) -> [(Type
TInt,String
r)]
("bool",r :: String
r) -> [(Type
TBool,String
r)]
("string",r :: String
r) -> [(Type
TString,String
r)]
("double",r :: String
r) -> [(Type
TDouble,String
r)]
("dateTime.iso8601",r :: String
r) -> [(Type
TDateTime,String
r)]
("base64",r :: String
r) -> [(Type
TBase64,String
r)]
("struct",r :: String
r) -> [(Type
TStruct,String
r)]
("array",r :: String
r) -> [(Type
TArray,String
r)]
("nil",r :: String
r) -> [(Type
TNil,String
r)]
structGetValue :: MonadFail m => String -> Value -> Err m Value
structGetValue :: String -> Value -> Err m Value
structGetValue n :: String
n (ValueStruct t :: [(String, Value)]
t) =
String -> Maybe Value -> Err m Value
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM ("Unknown member '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'") (String -> [(String, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n [(String, Value)]
t)
structGetValue _ _ = String -> Err m Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Value is not a struct"
faultStruct :: Int -> String -> Value
faultStruct :: Int -> String -> Value
faultStruct code :: Int
code str :: String
str = [(String, Value)] -> Value
ValueStruct [("faultCode",Int -> Value
ValueInt Int
code),
("faultString",String -> Value
ValueString String
str)]
onlyOneResult :: MonadFail m => [Value] -> Err m Value
onlyOneResult :: [Value] -> Err m Value
onlyOneResult [] = String -> Err m Value
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Method returned no result"
onlyOneResult [x :: Value
x] = Value -> Err m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
onlyOneResult _ = String -> Err m Value
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "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 :: Value -> Err m a
typeError v :: 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
$ \t :: a
t ->
String -> Err m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("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]
++ "', 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]
++ "'") Err m a -> Err m a -> Err m a
forall a. a -> a -> a
`asTypeOf` a -> Err m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t
withType :: (a -> Err m a) -> Err m a
withType :: (a -> Err m a) -> Err m a
withType f :: 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 :: (Value -> Maybe a) -> Value -> Err m a
simpleFromValue f :: Value -> Maybe a
f v :: 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 (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 :: Value -> Err m Value
fromValue = Value -> Err m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Err m Value) -> (Value -> Value) -> Value -> Err m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
forall a. a -> a
id
getType :: Value -> Type
getType _ = Type
TUnknown
instance XmlRpcType Int where
toValue :: Int -> Value
toValue = Int -> Value
ValueInt
fromValue :: 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 x :: Int
x) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
f _ = Maybe Int
forall a. Maybe a
Nothing
getType :: Int -> Type
getType _ = Type
TInt
instance XmlRpcType Bool where
toValue :: Bool -> Value
toValue = Bool -> Value
ValueBool
fromValue :: 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 x :: Bool
x) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
x
f _ = Maybe Bool
forall a. Maybe a
Nothing
getType :: Bool -> Type
getType _ = Type
TBool
instance OVERLAPPING_ XmlRpcType String where
toValue :: String -> Value
toValue = String -> Value
ValueString
fromValue :: 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 x :: String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
f (ValueUnwrapped x :: String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
f _ = Maybe String
forall a. Maybe a
Nothing
getType :: String -> Type
getType _ = 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 :: Value -> Err m Text
fromValue = ((String -> Text) -> ExceptT String m String -> Err m Text
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Text
T.pack) (ExceptT String m String -> Err m Text)
-> (Value -> ExceptT String m String) -> Value -> Err 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
fromValue
getType :: Text -> Type
getType _ = Type
TString
instance XmlRpcType BS.ByteString where
toValue :: ByteString -> Value
toValue = ByteString -> Value
ValueBase64
fromValue :: 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 x :: ByteString
x) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
x
f _ = Maybe ByteString
forall a. Maybe a
Nothing
getType :: ByteString -> Type
getType _ = Type
TBase64
instance XmlRpcType Double where
toValue :: Double -> Value
toValue = Double -> Value
ValueDouble
fromValue :: 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 x :: Double
x) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x
f _ = Maybe Double
forall a. Maybe a
Nothing
getType :: Double -> Type
getType _ = Type
TDouble
instance XmlRpcType LocalTime where
toValue :: LocalTime -> Value
toValue = LocalTime -> Value
ValueDateTime
fromValue :: 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 x :: LocalTime
x) = LocalTime -> Maybe LocalTime
forall a. a -> Maybe a
Just LocalTime
x
f _ = Maybe LocalTime
forall a. Maybe a
Nothing
getType :: LocalTime -> Type
getType _ = 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 :: Value -> Err m CalendarTime
fromValue = (LocalTime -> CalendarTime)
-> ExceptT String m LocalTime -> Err m CalendarTime
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LocalTime -> CalendarTime
localTimeToCalendarTime (ExceptT String m LocalTime -> Err m CalendarTime)
-> (Value -> ExceptT String m LocalTime)
-> Value
-> Err 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
fromValue
getType :: CalendarTime -> Type
getType _ = Type
TDateTime
instance XmlRpcType () where
toValue :: () -> Value
toValue = Value -> () -> Value
forall a b. a -> b -> a
const Value
ValueNil
fromValue :: 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 ValueNil = () -> Maybe ()
forall a. a -> Maybe a
Just ()
f _ = 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 :: Value -> Err m [a]
fromValue v :: Value
v = case Value
v of
ValueArray xs :: [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)
mapM Value -> ExceptT String m a
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue [Value]
xs
_ -> Value -> Err m [a]
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v
getType :: [a] -> Type
getType _ = Type
TArray
instance OVERLAPPING_ XmlRpcType a => XmlRpcType [(String,a)] where
toValue :: [(String, a)] -> Value
toValue xs :: [(String, a)]
xs = [(String, Value)] -> Value
ValueStruct [(String
n, a -> Value
forall a. XmlRpcType a => a -> Value
toValue a
v) | (n :: String
n,v :: a
v) <- [(String, a)]
xs]
fromValue :: Value -> Err m [(String, a)]
fromValue v :: Value
v = case Value
v of
ValueStruct xs :: [(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)
mapM (\ (n :: String
n,v' :: 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
fromValue Value
v')) [(String, Value)]
xs
_ -> Value -> Err m [(String, a)]
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
typeError Value
v
getType :: [(String, a)] -> Type
getType _ = 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 (v :: a
v,w :: b
w,x :: c
x,y :: d
y,z :: 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 :: Value -> Err m (a, b, c, d, e)
fromValue (ValueArray [v :: Value
v,w :: Value
w,x :: Value
x,y :: Value
y,z :: 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
-> Err 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
fromValue Value
v) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
w) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
x)
(Value -> ExceptT String m d
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
y) (Value -> ExceptT String m e
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
z)
fromValue _ = String -> Err m (a, b, c, d, e)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "Expected 5-element tuple!"
getType :: (a, b, c, d, e) -> Type
getType _ = Type
TArray
instance (XmlRpcType a, XmlRpcType b, XmlRpcType c, XmlRpcType d) =>
XmlRpcType (a,b,c,d) where
toValue :: (a, b, c, d) -> Value
toValue (w :: a
w,x :: b
x,y :: c
y,z :: 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 :: Value -> Err m (a, b, c, d)
fromValue (ValueArray [w :: Value
w,x :: Value
x,y :: Value
y,z :: 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
-> Err 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
fromValue Value
w) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
x) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
y) (Value -> ExceptT String m d
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
z)
fromValue _ = String -> Err m (a, b, c, d)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "Expected 4-element tuple!"
getType :: (a, b, c, d) -> Type
getType _ = Type
TArray
instance (XmlRpcType a, XmlRpcType b, XmlRpcType c) => XmlRpcType (a,b,c) where
toValue :: (a, b, c) -> Value
toValue (x :: a
x,y :: b
y,z :: 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 :: Value -> Err m (a, b, c)
fromValue (ValueArray [x :: Value
x,y :: Value
y,z :: Value
z]) =
(a -> b -> c -> (a, b, c))
-> ExceptT String m a
-> ExceptT String m b
-> ExceptT String m c
-> Err 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
fromValue Value
x) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
y) (Value -> ExceptT String m c
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
z)
fromValue _ = String -> Err m (a, b, c)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "Expected 3-element tuple!"
getType :: (a, b, c) -> Type
getType _ = Type
TArray
instance (XmlRpcType a, XmlRpcType b) => XmlRpcType (a,b) where
toValue :: (a, b) -> Value
toValue (x :: a
x,y :: 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 :: Value -> Err m (a, b)
fromValue (ValueArray [x :: Value
x,y :: Value
y]) = (a -> b -> (a, b))
-> ExceptT String m a -> ExceptT String m b -> Err 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
fromValue Value
x) (Value -> ExceptT String m b
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
y)
fromValue _ = String -> Err m (a, b)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError "Expected 2-element tuple."
getType :: (a, b) -> Type
getType _ = Type
TArray
getField :: (MonadFail m, XmlRpcType a) =>
String
-> [(String,Value)]
-> Err m a
getField :: String -> [(String, Value)] -> Err m a
getField x :: String
x xs :: [(String, Value)]
xs = String -> Maybe Value -> ExceptT String m Value
forall (m :: * -> *) a. MonadFail m => String -> Maybe a -> m a
maybeToM ("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]
++ " 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 -> Err m a) -> Err m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Err m a
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 :: String -> [(String, Value)] -> Err m (Maybe a)
getFieldMaybe x :: String
x xs :: [(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
Nothing -> Maybe a -> Err m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just v :: 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
fromValue Value
v)
toXRValue :: Value -> XR.Value
toXRValue :: Value -> Value
toXRValue (ValueInt x :: Int
x) = [Value_] -> Value
XR.Value [AInt -> Value_
XR.Value_AInt (String -> AInt
XR.AInt (Int -> String
showInt Int
x))]
toXRValue (ValueBool b :: Bool
b) = [Value_] -> Value
XR.Value [Boolean -> Value_
XR.Value_Boolean (String -> Boolean
XR.Boolean (Bool -> String
showBool Bool
b))]
toXRValue (ValueString s :: String
s) = [Value_] -> Value
XR.Value [AString -> Value_
XR.Value_AString (String -> AString
XR.AString (String -> String
showString String
s))]
toXRValue (ValueUnwrapped s :: String
s) = [Value_] -> Value
XR.Value [String -> Value_
XR.Value_Str String
s]
toXRValue (ValueDouble d :: Double
d) = [Value_] -> Value
XR.Value [ADouble -> Value_
XR.Value_ADouble (String -> ADouble
XR.ADouble (Double -> String
showDouble Double
d))]
toXRValue (ValueDateTime t :: 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 s :: ByteString
s) = [Value_] -> Value
XR.Value [Base64 -> Value_
XR.Value_Base64 (String -> Base64
XR.Base64 (ByteString -> String
showBase64 ByteString
s))]
toXRValue (ValueStruct xs :: [(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 xs :: [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 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 b :: Bool
b = if Bool
b then "1" else "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
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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace "&" "&"
showDouble :: Double -> String
showDouble :: Double -> String
showDouble d :: 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 ""
showDateTime :: LocalTime -> String
showDateTime :: LocalTime -> String
showDateTime t :: 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 name :: String
name vs :: [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 val :: Value
val) = Params -> MethodResponse
XR.MethodResponseParams ([Value] -> Params
toXRParams [Value
val])
toXRMethodResponse (Fault code :: Int
code str :: 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 vs :: [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 (n :: String
n, v :: 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 :: Value -> Err m Value
fromXRValue (XR.Value vs :: [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)
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)
(v :: Value_
v:_) -> Value_ -> Err m Value
forall (m :: * -> *).
MonadFail m =>
Value_ -> ExceptT String m Value
f Value_
v
where
notstr :: Value_ -> Bool
notstr (XR.Value_Str _) = Bool
False
notstr _ = Bool
True
unstr :: Value_ -> String
unstr (XR.Value_Str x :: String
x) = String
x
f :: Value_ -> ExceptT String m Value
f (XR.Value_I4 (XR.I4 x :: 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 x :: 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 x :: 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 x :: 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 x :: 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 x :: 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 x :: 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 x :: 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 ms :: [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)
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 xs :: [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)
mapM Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => Value -> Err m Value
fromXRValue [Value]
xs)
f (XR.Value_Nil (XR.Nil x :: ()
x)) = Value -> ExceptT String m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
ValueNil
fromXRMember :: MonadFail m => XR.Member -> Err m (String,Value)
fromXRMember :: Member -> Err m (String, Value)
fromXRMember (XR.Member (XR.Name n :: String
n) xv :: Value
xv) = (Value -> (String, Value))
-> ExceptT String m Value -> Err m (String, Value)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\v :: 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 :: String -> Err m Int
readInt s :: 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 "Error parsing integer" String
s
readBool :: MonadFail m => String -> Err m Bool
readBool :: String -> Err m Bool
readBool s :: 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 "Error parsing boolean" String
s
where readsBool :: ReadS Bool
readsBool "true" = [(Bool
True,"")]
readsBool "false" = [(Bool
False,"")]
readsBool "1" = [(Bool
True,"")]
readsBool "0" = [(Bool
False,"")]
readsBool _ = []
readString :: Monad m => String -> Err m String
readString :: String -> Err m String
readString = String -> Err m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Err m String)
-> (String -> String) -> String -> Err 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
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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace ">" ">"
readDouble :: MonadFail m => String -> Err m Double
readDouble :: String -> Err m Double
readDouble s :: 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 "Error parsing double" String
s
readDateTime :: MonadFail m => String -> Err m LocalTime
readDateTime :: String -> Err m LocalTime
readDateTime dt :: 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 (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> Err m LocalTime) -> String -> Err m LocalTime
forall a b. (a -> b) -> a -> b
$ "Error parsing dateTime '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dt String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'")
LocalTime -> Err m LocalTime
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 l :: LocalTime
l =
let (y :: Integer
y,mo :: Int
mo,d :: Int
d) = Day -> (Integer, 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
(_,_,wd :: Int
wd) = Day -> (Integer, Int, Int)
toWeekDate (LocalTime -> Day
localDay LocalTime
l)
(_,yd :: Int
yd) = Day -> (Integer, Int)
toOrdinalDate (LocalTime -> Day
localDay LocalTime
l)
in CalendarTime :: Int
-> Month
-> Int
-> Int
-> Int
-> Int
-> Integer
-> Day
-> Int
-> String
-> Int
-> Bool
-> CalendarTime
CalendarTime {
ctYear :: Int
ctYear = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y,
ctMonth :: Month
ctMonth = Int -> Month
forall a. Enum a => Int -> a
toEnum (Int
moInt -> Int -> Int
forall a. Num a => a -> a -> a
-1),
ctDay :: Int
ctDay = Int
d,
ctHour :: Int
ctHour = Int
h,
ctMin :: Int
ctMin = Int
mi,
ctSec :: Int
ctSec = Pico -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate Pico
s,
ctPicosec :: Integer
ctPicosec = 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` 7),
ctYDay :: Int
ctYDay = Int
yd,
ctTZName :: String
ctTZName = "UTC",
ctTZ :: Int
ctTZ = 0,
ctIsDST :: Bool
ctIsDST = Bool
False
}
calendarTimeToLocalTime :: CalendarTime -> LocalTime
calendarTimeToLocalTime :: CalendarTime -> LocalTime
calendarTimeToLocalTime ct :: CalendarTime
ct =
let (y :: Int
y,mo :: Month
mo,d :: Int
d) = (CalendarTime -> Int
ctYear CalendarTime
ct, CalendarTime -> Month
ctMonth CalendarTime
ct, CalendarTime -> Int
ctDay CalendarTime
ct)
(h :: Int
h,mi :: Int
mi,s :: Int
s) = (CalendarTime -> Int
ctHour CalendarTime
ct, CalendarTime -> Int
ctMin CalendarTime
ct, CalendarTime -> Int
ctSec CalendarTime
ct)
in LocalTime :: Day -> TimeOfDay -> LocalTime
LocalTime {
localDay :: Day
localDay = Integer -> Int -> Int -> Day
fromGregorian (Int -> Integer
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
+ 1) Int
d,
localTimeOfDay :: TimeOfDay
localTimeOfDay = TimeOfDay :: Int -> Int -> Pico -> TimeOfDay
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 :: String -> Err m ByteString
readBase64 = ByteString -> Err m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Err m ByteString)
-> (String -> ByteString) -> String -> Err 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 :: Params -> Err m [Value]
fromXRParams (XR.Params xps :: [Param]
xps) = (Param -> ExceptT String m Value) -> [Param] -> Err m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(XR.Param v :: 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 :: MethodCall -> Err m MethodCall
fromXRMethodCall (XR.MethodCall (XR.MethodName name :: String
name) params :: Maybe Params
params) =
([Value] -> MethodCall)
-> ExceptT String m [Value] -> Err 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 :: MethodResponse -> Err m MethodResponse
fromXRMethodResponse (XR.MethodResponseParams xps :: Params
xps) =
(Value -> MethodResponse)
-> ExceptT String m Value -> Err 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 (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 v :: 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 "faultCode" Value
struct
Int
code <- Value -> Err m Int
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
vcode
Value
vstr <- String -> Value -> ExceptT String m Value
forall (m :: * -> *). MonadFail m => String -> Value -> Err m Value
structGetValue "faultString" Value
struct
String
str <- Value -> Err m String
forall a (m :: * -> *).
(XmlRpcType a, MonadFail m) =>
Value -> Err m a
fromValue Value
vstr
MethodResponse -> Err m MethodResponse
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 :: String -> Err m MethodCall
parseCall c :: 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 "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 :: String -> Err m MethodResponse
parseResponse c :: 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 "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' :: Bool -> a -> ByteString
showXml' dtd :: Bool
dtd x :: a
x = case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
[CElem _ _] -> (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
_ -> String -> ByteString
BSL.pack ""