1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
-- |
-- Copyright : (c) Sam T. 2013
-- License : MIT
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- This module provides remote procedure call.
--
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-}
{-# LANGUAGE ExplicitForAll, KindSignatures #-}
{-# LANGUAGE ViewPatterns #-}
module Remote.KRPC
( module Remote.KRPC.Method, RemoteAddr
-- * Client
, call, async, await
-- * Server
, (==>), server
) where
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Control
import Control.Monad.IO.Class
import Data.BEncode
import Data.ByteString.Char8 as BC
import Data.List as L
import Data.Map as M
import Data.Set as S
import Data.Text as T
import Data.Text.Encoding as T
import Data.Typeable
import Network
import Remote.KRPC.Protocol
import Remote.KRPC.Method
data RPCException = RPCException KError
deriving (Show, Eq, Typeable)
instance Exception RPCException
type RemoteAddr = KRemoteAddr
queryCall :: BEncodable param
=> Extractable param
=> KRemote -> KRemoteAddr
-> Method param result -> param -> IO ()
queryCall sock addr m arg = sendMessage q addr sock
where
q = kquery (methodName m) (mkVals (methodParams m) (injector arg))
mkVals = L.zip
extractArgs :: [ParamName] -> Map ParamName BEncode -> Result [BEncode]
extractArgs as d = mapM f as
where
f x | Just y <- M.lookup x d = return y
| otherwise = Left ("not found key " ++ BC.unpack x)
{-# INLINE extractArgs #-}
-- TODO check scheme
getResult :: BEncodable result
=> Extractable result
=> KRemote -> KRemoteAddr
-> Method param result -> IO result
getResult sock addr m = do
resp <- recvResponse addr sock
case resp of
Left e -> throw (RPCException e)
Right (respVals -> dict) -> do
case extractArgs (methodVals m) dict >>= extractor of
Right vals -> return vals
Left e -> throw (RPCException (ProtocolError (T.pack e)))
-- TODO async call
-- | Makes remote procedure call. Throws RPCException if server
-- returns error or decode error occurred.
--
call :: (MonadBaseControl IO host, MonadIO host)
=> (BEncodable param, BEncodable result)
=> (Extractable param, Extractable result)
=> RemoteAddr
-> Method param result
-> param
-> host result
call addr m arg = liftIO $ withRemote $ \sock -> do
queryCall sock addr m arg
getResult sock addr m
newtype Async result = Async { waitResult :: IO result }
-- TODO document errorneous usage
async :: MonadIO host
=> (BEncodable param, BEncodable result)
=> (Extractable param, Extractable result)
=> RemoteAddr
-> Method param result
-> param
-> host (Async result)
async addr m arg = do
liftIO $ withRemote $ \sock ->
queryCall sock addr m arg
return $ Async $ withRemote $ \sock ->
getResult sock addr m
await :: MonadIO host => Async result -> host result
await = liftIO . waitResult
{-# INLINE await #-}
type HandlerBody remote = KQuery -> remote (Either KError KResponse)
type MethodHandler remote = (MethodName, HandlerBody remote)
-- we can safely erase types in (==>)
(==>) :: forall (remote :: * -> *) (param :: *) (result :: *).
(BEncodable param, BEncodable result)
=> (Extractable param, Extractable result)
=> Monad remote
=> Method param result
-> (param -> remote result)
-> MethodHandler remote
{-# INLINE (==>) #-}
m ==> body = (methodName m, newbody)
where
{-# INLINE newbody #-}
newbody q =
case extractArgs (methodParams m) (queryArgs q) >>= extractor of
Left e -> return (Left (ProtocolError (T.pack e)))
Right a -> do
r <- body a
return (Right (kresponse (mkVals (methodVals m) (injector r))))
mkVals :: [ValName] -> [BEncode] -> [(ValName, BEncode)]
mkVals = L.zip
-- TODO: allow forkIO
server :: (MonadBaseControl IO remote, MonadIO remote)
=> PortNumber
-> [MethodHandler remote]
-> remote ()
server servport handlers = do
remoteServer servport $ \_ q -> do
case dispatch (queryMethod q) of
Nothing -> return $ Left $ MethodUnknown (decodeUtf8 (queryMethod q))
Just m -> invoke m q
where
handlerMap = M.fromList handlers
dispatch s = M.lookup s handlerMap
invoke m q = m q
bimap f _ (Left x) = Left (f x)
bimap _ g (Right x) = Right (g x)
|
