module Network.RTorrent.Command.Internals (
(:*:)(..)
, Command (Ret, commandCall, commandValue, levels)
, AnyCommand (..)
, RTMethodCall (..)
, runRTMethodCall
, mkRTMethodCall
, parseSingle
, getArray
, getArray'
, single
, decodeUtf8
) where
import Control.Applicative
import Control.DeepSeq
import Control.Monad.Except
import Control.Monad.Identity
import qualified Codec.Binary.UTF8.String as U
import Data.List.Split (splitPlaces)
import Network.XmlRpc.Internals
data (:*:) a b = (:*:) !a !b
infixr 6 :*:
instance (NFData a, NFData b) => NFData (a :*: b) where
rnf (a :*: b) = rnf a `seq` rnf b
instance (Show a, Show b) => Show (a :*: b) where
show (a :*: b) = show a ++ " :*: " ++ show b
instance (Command a, Command b) => Command (a :*: b) where
type Ret (a :*: b) = Ret a :*: Ret b
commandCall (a :*: b) = RTMethodCall $ ValueArray (val a ++ val b)
where
val :: Command c => c -> [Value]
val = getArray' . runRTMethodCall . commandCall
commandValue (a :*: b) (ValueArray xs) =
(:*:) <$> (commandValue a . ValueArray $ as)
<*> (commandValue b . ValueArray $ bs)
where
(as, bs) = splitAt (levels a) xs
commandValue _ _ = fail "commandValue in Command (a :*: b) instance failed"
levels (a :*: b) = levels a + levels b
getArray :: Monad m => Value -> m [Value]
getArray (ValueArray ar) = return ar
getArray _ = fail "getArray in Network.RTorrent.Commands failed"
getArray' :: Value -> [Value]
getArray' (ValueArray ar) = ar
getArray' _ = error "getArray' in Network.RTorrent.Commands failed"
single :: Monad m => Value -> m Value
single (ValueArray [ar]) = return ar
single v@(ValueStruct vars) = maybe
err
(\(c, s) -> do
i <- int c
s' <- str s
fail $ "Server returned error " ++ show i ++
": " ++ s')
(liftA2 (,) (lookup "faultCode" vars)
(lookup "faultString" vars))
where
int (ValueInt i) = return i
int _ = err
str (ValueString s) = return s
str _ = err
err :: Monad m => m a
err = fail $ "Failed to match a singleton array, got: " ++ show v
single v = fail $ "Failed to match a singleton array, got: " ++ show v
parseValue :: (Monad m, XmlRpcType a) => Value -> m a
parseValue = fromRight . runIdentity . runExceptT . fromValue
where
fromRight (Right r) = return r
fromRight (Left e) = fail $ "parseValue failed: " ++ e
parseSingle :: (Monad m, XmlRpcType a) => Value -> m a
parseSingle = parseValue <=< single <=< single
decodeUtf8 :: String -> String
decodeUtf8 = U.decodeString
newtype RTMethodCall = RTMethodCall Value
deriving Show
runRTMethodCall :: RTMethodCall -> Value
runRTMethodCall (RTMethodCall v) = v
mkRTMethodCall :: String
-> [Value]
-> RTMethodCall
mkRTMethodCall name params = RTMethodCall $ ValueArray [ValueStruct
[ ("methodName", ValueString name)
, ("params", ValueArray params)]]
class Command a where
type Ret a
commandCall :: a -> RTMethodCall
commandValue :: (Applicative m, Monad m) =>
a -> Value -> m (Ret a)
levels :: a -> Int
levels _ = 1
data AnyCommand where
AnyCommand :: Command a => a -> AnyCommand
instance Command AnyCommand where
type Ret AnyCommand = Value
commandCall (AnyCommand cmd) = commandCall cmd
commandValue _ = single <=< single
levels (AnyCommand cmd) = levels cmd
instance Command a => Command [a] where
type Ret [a] = [Ret a]
commandCall = RTMethodCall . ValueArray
. concatMap ( getArray'
. runRTMethodCall . commandCall)
commandValue cmds =
zipWithM (\cmd -> commandValue cmd . ValueArray) cmds
. splitPlaces (map levels cmds)
<=< getArray
levels = sum . map levels