diff options
Diffstat (limited to 'src/Network/KRPC.hs')
-rw-r--r-- | src/Network/KRPC.hs | 195 |
1 files changed, 14 insertions, 181 deletions
diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index a96d8da9..09d1c5b2 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs | |||
@@ -97,190 +97,23 @@ | |||
97 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | 97 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} |
98 | {-# LANGUAGE FunctionalDependencies #-} | 98 | {-# LANGUAGE FunctionalDependencies #-} |
99 | module Network.KRPC | 99 | module Network.KRPC |
100 | ( KRPC (..) | 100 | ( -- * Methods |
101 | Method | ||
102 | , KRPC (..) | ||
101 | 103 | ||
102 | -- * Exception | 104 | -- * RPC |
103 | , KError (..) | 105 | , handler |
104 | 106 | , query | |
105 | -- * Method | ||
106 | , Method(..) | ||
107 | 107 | ||
108 | -- * Client | 108 | -- * Manager |
109 | , call | 109 | , MonadKRPC (..) |
110 | , newManager | ||
111 | -- , closeManager | ||
110 | 112 | ||
111 | -- * Server | 113 | -- * Exceptions |
112 | , MethodHandler | 114 | , KError (..) |
113 | , handler | ||
114 | , server | ||
115 | ) where | 115 | ) where |
116 | 116 | ||
117 | import Control.Applicative | ||
118 | import Control.Exception.Lifted as Lifted | ||
119 | import Control.Monad | ||
120 | import Control.Monad.Trans.Control | ||
121 | import Control.Monad.IO.Class | ||
122 | import Data.BEncode as BE | ||
123 | import Data.ByteString.Char8 as BC | ||
124 | import Data.ByteString.Lazy as BL | ||
125 | import Data.List as L | ||
126 | import Data.Monoid | ||
127 | import Data.String | ||
128 | import Data.Typeable | ||
129 | import Network | ||
130 | import Network.Socket | ||
131 | import Network.Socket.ByteString as BS | ||
132 | |||
133 | import Network.KRPC.Message | 117 | import Network.KRPC.Message |
134 | 118 | import Network.KRPC.Method | |
135 | 119 | import Network.KRPC.Manager \ No newline at end of file | |
136 | class (BEncode req, BEncode resp) => KRPC req resp | req -> resp where | ||
137 | method :: Method req resp | ||
138 | |||
139 | -- | Method datatype used to describe name, parameters and return | ||
140 | -- values of procedure. Client use a method to /invoke/, server | ||
141 | -- /implements/ the method to make the actual work. | ||
142 | -- | ||
143 | -- We use the following fantom types to ensure type-safiety: | ||
144 | -- | ||
145 | -- * param: Type of method parameters. Ordinary Tuple type used | ||
146 | -- to specify more than one parameter, so for example @Method | ||
147 | -- (Int, Int) result@ will take two arguments. | ||
148 | -- | ||
149 | -- * result: Type of return value of the method. Similarly, | ||
150 | -- tuple used to specify more than one return value, so for | ||
151 | -- exsample @Method (Foo, Bar) (Bar, Foo)@ will take two arguments | ||
152 | -- and return two values. | ||
153 | -- | ||
154 | newtype Method param result = Method MethodName | ||
155 | deriving (Eq, Ord, IsString, BEncode) | ||
156 | |||
157 | instance (Typeable a, Typeable b) => Show (Method a b) where | ||
158 | showsPrec _ = showsMethod | ||
159 | |||
160 | showsMethod :: forall a. forall b. Typeable a => Typeable b | ||
161 | => Method a b -> ShowS | ||
162 | showsMethod (Method name) = | ||
163 | shows name <> | ||
164 | showString " :: " <> | ||
165 | shows paramsTy <> | ||
166 | showString " -> " <> | ||
167 | shows valuesTy | ||
168 | where | ||
169 | impossible = error "KRPC.showsMethod: impossible" | ||
170 | paramsTy = typeOf (impossible :: a) | ||
171 | valuesTy = typeOf (impossible :: b) | ||
172 | |||
173 | {----------------------------------------------------------------------- | ||
174 | -- Client | ||
175 | -----------------------------------------------------------------------} | ||
176 | |||
177 | sendMessage :: BEncode msg => msg -> SockAddr -> Socket -> IO () | ||
178 | sendMessage msg addr sock = sendManyTo sock (BL.toChunks (encode msg)) addr | ||
179 | {-# INLINE sendMessage #-} | ||
180 | |||
181 | maxMsgSize :: Int | ||
182 | --maxMsgSize = 512 -- release: size of payload of one udp packet | ||
183 | maxMsgSize = 64 * 1024 -- bench: max UDP MTU | ||
184 | {-# INLINE maxMsgSize #-} | ||
185 | |||
186 | recvResponse :: Socket -> IO (Either KError KResponse) | ||
187 | recvResponse sock = do | ||
188 | (raw, _) <- BS.recvFrom sock maxMsgSize | ||
189 | return $ case decode raw of | ||
190 | Right resp -> Right resp | ||
191 | Left decE -> Left $ case decode raw of | ||
192 | Right kerror -> kerror | ||
193 | _ -> KError ProtocolError (BC.pack decE) undefined | ||
194 | |||
195 | withRemote :: (MonadBaseControl IO m, MonadIO m) => (Socket -> m a) -> m a | ||
196 | withRemote = bracket (liftIO (socket AF_INET6 Datagram defaultProtocol)) | ||
197 | (liftIO . sClose) | ||
198 | {-# SPECIALIZE withRemote :: (Socket -> IO a) -> IO a #-} | ||
199 | |||
200 | getResult :: BEncode result => Socket -> IO result | ||
201 | getResult sock = do | ||
202 | KResponse {..} <- either throw return =<< recvResponse sock | ||
203 | case fromBEncode respVals of | ||
204 | Left msg -> throw $ KError ProtocolError (BC.pack msg) respId | ||
205 | Right r -> return r | ||
206 | |||
207 | -- | Makes remote procedure call. Throws RPCException on any error | ||
208 | -- occurred. | ||
209 | call :: forall req resp host. | ||
210 | (MonadBaseControl IO host, MonadIO host, KRPC req resp) | ||
211 | => SockAddr -> req -> host resp | ||
212 | call addr arg = liftIO $ withRemote $ \sock -> do | ||
213 | sendMessage (KQuery (toBEncode arg) name undefined) addr sock | ||
214 | getResult sock | ||
215 | where | ||
216 | Method name = method :: Method req resp | ||
217 | |||
218 | {----------------------------------------------------------------------- | ||
219 | -- Server | ||
220 | -----------------------------------------------------------------------} | ||
221 | |||
222 | type HandlerBody remote = SockAddr -> KQuery -> remote (Either KError KResponse) | ||
223 | |||
224 | -- | Procedure signature and implementation binded up. | ||
225 | type MethodHandler remote = (MethodName, HandlerBody remote) | ||
226 | |||
227 | -- | Similar to '==>@' but additionally pass caller address. | ||
228 | handler :: forall (remote :: * -> *) (req :: *) (resp :: *). | ||
229 | (KRPC req resp, Monad remote) | ||
230 | => (SockAddr -> req -> remote resp) -> MethodHandler remote | ||
231 | handler body = (name, newbody) | ||
232 | where | ||
233 | Method name = method :: Method req resp | ||
234 | |||
235 | {-# INLINE newbody #-} | ||
236 | newbody addr KQuery {..} = | ||
237 | case fromBEncode queryArgs of | ||
238 | Left e -> return $ Left $ KError ProtocolError (BC.pack e) queryId | ||
239 | Right a -> do | ||
240 | r <- body addr a | ||
241 | return $ Right $ KResponse (toBEncode r) queryId | ||
242 | |||
243 | sockAddrFamily :: SockAddr -> Family | ||
244 | sockAddrFamily (SockAddrInet _ _ ) = AF_INET | ||
245 | sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 | ||
246 | sockAddrFamily (SockAddrUnix _ ) = AF_UNIX | ||
247 | |||
248 | -- | Run server using a given port. Method invocation should be done manually. | ||
249 | remoteServer :: (MonadBaseControl IO remote, MonadIO remote) | ||
250 | => SockAddr -- ^ Port number to listen. | ||
251 | -> (SockAddr -> KQuery -> remote (Either KError KResponse)) | ||
252 | -> remote () | ||
253 | remoteServer servAddr action = bracket (liftIO bindServ) (liftIO . sClose) loop | ||
254 | where | ||
255 | bindServ = do | ||
256 | let family = sockAddrFamily servAddr | ||
257 | sock <- socket family Datagram defaultProtocol | ||
258 | when (family == AF_INET6) $ do | ||
259 | setSocketOption sock IPv6Only 0 | ||
260 | bindSocket sock servAddr | ||
261 | return sock | ||
262 | |||
263 | loop sock = forever $ do | ||
264 | (bs, addr) <- liftIO $ BS.recvFrom sock maxMsgSize | ||
265 | reply <- handleMsg bs addr | ||
266 | liftIO $ sendMessage reply addr sock | ||
267 | where | ||
268 | handleMsg bs addr = case decode bs of | ||
269 | Right query -> (either toBEncode toBEncode <$> action addr query) | ||
270 | `Lifted.catch` (return . toBEncode . (`serverError` undefined )) | ||
271 | Left decodeE -> return $ toBEncode $ | ||
272 | KError ProtocolError (BC.pack decodeE) undefined | ||
273 | |||
274 | -- | Run RPC server on specified port by using list of handlers. | ||
275 | -- Server will dispatch procedure specified by callee, but note that | ||
276 | -- it will not create new thread for each connection. | ||
277 | -- | ||
278 | server :: (MonadBaseControl IO remote, MonadIO remote) | ||
279 | => SockAddr -- ^ Port used to accept incoming connections. | ||
280 | -> [MethodHandler remote] -- ^ Method table. | ||
281 | -> remote () | ||
282 | server servAddr handlers = do | ||
283 | remoteServer servAddr $ \addr q @ KQuery {..} -> do | ||
284 | case L.lookup queryMethod handlers of | ||
285 | Nothing -> return $ Left $ KError MethodUnknown queryMethod queryId | ||
286 | Just m -> m addr q | ||