module Network.RTorrent.Action.Internals (
Action (..)
, simpleAction
, pureAction
, sequenceActions
, (<+>)
, Param (..)
, ActionB (..)
, AllAction (..)
, allToMulti
) where
import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.Traversable hiding (mapM)
import Network.XmlRpc.Internals
import Network.RTorrent.Command.Internals
import Network.RTorrent.Priority
data Action i a
= Action [(String, [Param])] (forall m. (Monad m, Applicative m) => Value -> m a) i
newtype ActionB i a = ActionB { runActionB :: i -> Action i a}
simpleAction :: XmlRpcType a =>
String
-> [Param]
-> i
-> Action i a
simpleAction cmd params = Action [(cmd, params)] parseSingle
instance Functor (Action i) where
fmap f (Action cmds p fid) = Action cmds (fmap f . p) fid
instance Functor (ActionB i) where
fmap f = ActionB . (fmap f .) . runActionB
instance Applicative (ActionB i) where
pure a = ActionB $ Action [] (const (pure a))
(ActionB a) <*> (ActionB b) = ActionB $ \tid -> let
parse :: (Monad m, Applicative m) => (Value -> m (a -> b)) -> (Value -> m a) -> Value -> m b
parse parseA parseB arr = do
(valsA, valsB) <- splitAt len <$> getArray arr
parseA (ValueArray valsA)
<*> parseB (ValueArray valsB)
len = length cmdsA
Action cmdsA pA _ = a tid
Action cmdsB pB _ = b tid
in Action (cmdsA ++ cmdsB) (parse pA pB) tid
instance Monoid a => Monoid (ActionB i a) where
mempty = pure mempty
mappend = liftA2 mappend
instance XmlRpcType i => Command (Action i a) where
type Ret (Action i a) = a
commandCall (Action cmds _ tid) =
RTMethodCall
. ValueArray
. concatMap (\(cmd, params) ->
getArray'
. runRTMethodCall $ mkRTMethodCall cmd
(toValue tid : map toValue params))
$ cmds
commandValue (Action _ parse _) = parse
levels (Action cmds _ _) = length cmds
data Param =
PString String
| PInt Int
| PTorrentPriority TorrentPriority
| PFilePriority FilePriority
instance Show Param where
show (PString str) = show str
show (PInt i) = show i
show (PTorrentPriority p) = show (fromEnum p)
show (PFilePriority p) = show (fromEnum p)
instance XmlRpcType Param where
toValue (PString str) = toValue str
toValue (PInt i) = toValue i
toValue (PTorrentPriority p) = toValue p
toValue (PFilePriority p) = toValue p
fromValue = fail "No fromValue for Params"
getType _ = TUnknown
sequenceActions :: Traversable f => f (i -> Action i a) -> i -> Action i (f a)
sequenceActions = runActionB . traverse ActionB
pureAction :: a -> i -> Action i a
pureAction a = Action [] (const (return a))
infixr 6 <+>
(<+>) :: (i -> Action i a) -> (i -> Action i b) -> i -> Action i (a :*: b)
a <+> b = runActionB $ (:*:) <$> ActionB a <*> ActionB b
data AllAction i a = AllAction i String (i -> Action i a)
makeMultiCall :: [(String, [Param])] -> [String]
makeMultiCall = ("" :)
. map (\(cmd, params) -> cmd ++ "=" ++ makeList params)
where
makeList :: Show a => [a] -> String
makeList params = ('{' :) . go params $ "}"
where
go :: Show a => [a] -> ShowS
go [x] = shows x
go (x:xs) = shows x . (',' :) . go xs
go [] = id
wrapForParse :: Monad m => Value -> m [Value]
wrapForParse = mapM (
return . ValueArray
. map (ValueArray . (:[]))
<=< getArray)
<=< getArray <=< single <=< single
allToMulti :: AllAction i a -> j -> Action j [a]
allToMulti (AllAction emptyId multicall action) =
Action [(multicall, map PString $ makeMultiCall cmds)]
(mapM parse <=< wrapForParse)
where
Action cmds parse _ = action emptyId
instance Command (AllAction i a) where
type Ret (AllAction i a) = [a]
commandCall (AllAction emptyId multicall action) =
mkRTMethodCall multicall
. map ValueString
. makeMultiCall
$ cmds
where
Action cmds _ _ = action emptyId
commandValue (AllAction emptyId _ action) =
mapM parse <=< wrapForParse
where
Action _ parse _ = action emptyId