{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- HaXR backend.
--
-- This module provides 'Transport' and 'Atom' instances for HaXR.

module Data.Autolib.Transport.HaXR (
    -- instances only
) where

import Data.Autolib.Transport.Atom
import Data.Autolib.Transport.Class

import qualified Data.ByteString as B
import Data.ByteString (ByteString)
import Control.Arrow (second)

import qualified Data.String.UTF8 as U
import Data.Word
import Data.Text (Text, pack, unpack)

import Network.XmlRpc.Internals

instance ConvertAtom Value Bool where
    fromAtom :: Value -> Error Bool
fromAtom Value
x = do ValueBool x' <- Value -> Error Value
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x; return x'
    toAtom :: Bool -> Value
toAtom = Bool -> Value
ValueBool

instance ConvertAtom Value Double where
    fromAtom :: Value -> Error Double
fromAtom Value
x = do ValueDouble x' <- Value -> Error Value
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x; return x'
    toAtom :: Double -> Value
toAtom = Double -> Value
ValueDouble

-- Note: We encode integers as strings because XMLRPC limits Ints to 32 bits.
instance ConvertAtom Value Integer where
    fromAtom :: Value -> Error Integer
fromAtom Value
x = do ValueString x' <- Value -> Error Value
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x; return (read x')
    toAtom :: Integer -> Value
toAtom = String -> Value
ValueString (String -> Value) -> (Integer -> String) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show

instance ConvertAtom Value String where
    fromAtom :: Value -> Error String
fromAtom Value
x = do ValueString x' <- Value -> Error Value
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x; return x'
    toAtom :: String -> Value
toAtom = String -> Value
ValueString

instance ConvertAtom Value Text where
    fromAtom :: Value -> Error Text
fromAtom Value
x = do ValueString x' <- Value -> Error Value
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x; return (pack x')
    toAtom :: Text -> Value
toAtom = String -> Value
ValueString (String -> Value) -> (Text -> String) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack

du :: String -> String
du :: String -> String
du = UTF8 [Word8] -> String
forall string index.
UTF8Bytes string index =>
UTF8 string -> String
U.toString (UTF8 [Word8] -> String)
-> (String -> UTF8 [Word8]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> UTF8 [Word8]
forall string. string -> UTF8 string
U.fromRep ([Word8] -> UTF8 [Word8])
-> (String -> [Word8]) -> String -> UTF8 [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word8) ([Int] -> [Word8]) -> (String -> [Int]) -> String -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
forall a. Enum a => a -> Int
fromEnum

eu :: String -> String
eu :: String -> String
eu = (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
forall a. Enum a => Int -> a
toEnum ([Int] -> String) -> (String -> [Int]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Int) -> [Word8] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word8 -> Int) ([Word8] -> [Int]) -> (String -> [Word8]) -> String -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTF8 [Word8] -> [Word8]
forall string. UTF8 string -> string
U.toRep (UTF8 [Word8] -> [Word8])
-> (String -> UTF8 [Word8]) -> String -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UTF8 [Word8]
forall string index.
UTF8Bytes string index =>
String -> UTF8 string
U.fromString

instance ConvertAtom Value ByteString where
    fromAtom :: Value -> Error ByteString
fromAtom Value
x = do
        ValueBase64 x' <- Value -> Error Value
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x
        return $ x' -- B.pack . map (fromIntegral . fromEnum) $ x'
    toAtom :: ByteString -> Value
toAtom = ByteString -> Value
ValueBase64 -- map (toEnum . fromIntegral) . B.unpack

instance Transport Value Value where
    encode :: Trans Value -> Value
encode (TrAtom Value
x)    = Value
x
    encode (TrArray [Trans Value]
xs)  = [Value] -> Value
ValueArray  ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (Trans Value -> Value) -> [Trans Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Trans Value -> Value
forall base atom. Transport base atom => Trans atom -> base
encode [Trans Value]
xs
    encode (TrObject [(String, Trans Value)]
xs) = [(String, Value)] -> Value
ValueStruct ([(String, Value)] -> Value)
-> ([(String, Trans Value)] -> [(String, Value)])
-> [(String, Trans Value)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Trans Value) -> (String, Value))
-> [(String, Trans Value)] -> [(String, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Trans Value -> Value) -> (String, Trans Value) -> (String, Value)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Trans Value -> Value
forall base atom. Transport base atom => Trans atom -> base
encode) ([(String, Trans Value)] -> Value)
-> [(String, Trans Value)] -> Value
forall a b. (a -> b) -> a -> b
$ [(String, Trans Value)]
xs

    decode :: Value -> Error (Trans Value)
decode (ValueArray [Value]
xs)  = [Trans Value] -> Trans Value
forall atom. [Trans atom] -> Trans atom
TrArray ([Trans Value] -> Trans Value)
-> Error [Trans Value] -> Error (Trans Value)
forall a b. (a -> b) -> Error a -> Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Value -> Error (Trans Value)) -> [Value] -> Error [Trans 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 -> Error (Trans Value)
forall base atom. Transport base atom => base -> Error (Trans atom)
decode [Value]
xs
    decode (ValueStruct [(String, Value)]
xs) = [(String, Trans Value)] -> Trans Value
forall atom. [(String, Trans atom)] -> Trans atom
TrObject ([(String, Trans Value)] -> Trans Value)
-> Error [(String, Trans Value)] -> Error (Trans Value)
forall a b. (a -> b) -> Error a -> Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((String, Value) -> Error (String, Trans Value))
-> [(String, Value)] -> Error [(String, Trans 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 -> Error (Trans Value))
-> (String, Value) -> Error (String, Trans Value)
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> (x, a) -> m (x, b)
secondM Value -> Error (Trans Value)
forall base atom. Transport base atom => base -> Error (Trans atom)
decode) [(String, Value)]
xs
    decode Value
x                = Value -> Trans Value
forall atom. atom -> Trans atom
TrAtom (Value -> Trans Value) -> Error Value -> Error (Trans Value)
forall a b. (a -> b) -> Error a -> Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Value -> Error Value
forall a. a -> Error a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
x

secondM :: Monad m => (a -> m b) -> (x, a) -> m (x, b)
secondM :: forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> (x, a) -> m (x, b)
secondM a -> m b
f (x
x, a
a) = a -> m b
f a
a m b -> (b -> m (x, b)) -> m (x, b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (x, b) -> m (x, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((x, b) -> m (x, b)) -> (b -> (x, b)) -> b -> m (x, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) x
x