diff options
-rw-r--r-- | krpc.cabal | 1 | ||||
-rw-r--r-- | src/Network/KRPC.hs | 2 | ||||
-rw-r--r-- | src/Network/KRPC/Scheme.hs | 82 |
3 files changed, 1 insertions, 84 deletions
@@ -38,7 +38,6 @@ library | |||
38 | hs-source-dirs: src | 38 | hs-source-dirs: src |
39 | exposed-modules: Network.KRPC | 39 | exposed-modules: Network.KRPC |
40 | , Network.KRPC.Protocol | 40 | , Network.KRPC.Protocol |
41 | , Network.KRPC.Scheme | ||
42 | build-depends: base == 4.* | 41 | build-depends: base == 4.* |
43 | , bytestring >= 0.10 | 42 | , bytestring >= 0.10 |
44 | 43 | ||
diff --git a/src/Network/KRPC.hs b/src/Network/KRPC.hs index 8cc3fcab..f891d5a0 100644 --- a/src/Network/KRPC.hs +++ b/src/Network/KRPC.hs | |||
@@ -334,7 +334,7 @@ infix 1 ==>@ | |||
334 | -- it will not create new thread for each connection. | 334 | -- it will not create new thread for each connection. |
335 | -- | 335 | -- |
336 | server :: (MonadBaseControl IO remote, MonadIO remote) | 336 | server :: (MonadBaseControl IO remote, MonadIO remote) |
337 | => SockAddr -- ^ Port used to accept incoming connections. | 337 | => SockAddr -- ^ Port used to accept incoming connections. |
338 | -> [MethodHandler remote] -- ^ Method table. | 338 | -> [MethodHandler remote] -- ^ Method table. |
339 | -> remote () | 339 | -> remote () |
340 | server servAddr handlers = do | 340 | server servAddr handlers = do |
diff --git a/src/Network/KRPC/Scheme.hs b/src/Network/KRPC/Scheme.hs deleted file mode 100644 index 244f035d..00000000 --- a/src/Network/KRPC/Scheme.hs +++ /dev/null | |||
@@ -1,82 +0,0 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- This module provides message scheme validation for core protocol | ||
9 | -- messages from 'Remote.KRPC.Procotol'. This module should be used | ||
10 | -- with 'Remote.KRPC.Protocol', otherwise (if you are using 'Remote.KRPC') | ||
11 | -- this module seems to be useless. | ||
12 | -- | ||
13 | {-# LANGUAGE DefaultSignatures #-} | ||
14 | {-# LANGUAGE TypeSynonymInstances #-} | ||
15 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
16 | {-# LANGUAGE FunctionalDependencies #-} | ||
17 | module Network.KRPC.Scheme | ||
18 | ( KMessage(..) | ||
19 | , KQueryScheme(..), methodQueryScheme | ||
20 | , KResponseScheme(..), methodRespScheme | ||
21 | ) where | ||
22 | |||
23 | import Control.Applicative | ||
24 | import Data.BEncode.BDict as BS | ||
25 | import Data.BEncode.Types as BS | ||
26 | |||
27 | import Network.KRPC.Protocol | ||
28 | import Network.KRPC | ||
29 | |||
30 | |||
31 | -- | Used to validate any message by its scheme | ||
32 | -- | ||
33 | -- forall m. m `validate` scheme m | ||
34 | -- | ||
35 | class KMessage message scheme | message -> scheme where | ||
36 | -- | Get a message scheme. | ||
37 | scheme :: message -> scheme | ||
38 | |||
39 | -- | Check a message with a scheme. | ||
40 | validate :: message -> scheme -> Bool | ||
41 | |||
42 | default validate :: Eq scheme => message -> scheme -> Bool | ||
43 | validate = (==) . scheme | ||
44 | {-# INLINE validate #-} | ||
45 | |||
46 | |||
47 | instance KMessage KError ErrorCode where | ||
48 | scheme = errorCode | ||
49 | {-# INLINE scheme #-} | ||
50 | |||
51 | data KQueryScheme = KQueryScheme { | ||
52 | qscMethod :: MethodName | ||
53 | , qscParams :: [ParamName] | ||
54 | } deriving (Show, Read, Eq, Ord) | ||
55 | |||
56 | bdictKeys :: BDict -> [BKey] | ||
57 | bdictKeys (Cons k _ xs) = k : bdictKeys xs | ||
58 | bdictKeys Nil = [] | ||
59 | |||
60 | instance KMessage KQuery KQueryScheme where | ||
61 | scheme q = KQueryScheme | ||
62 | { qscMethod = queryMethod q | ||
63 | , qscParams = bdictKeys $ queryArgs q | ||
64 | } | ||
65 | {-# INLINE scheme #-} | ||
66 | |||
67 | methodQueryScheme :: Method a b -> KQueryScheme | ||
68 | methodQueryScheme = KQueryScheme <$> methodName <*> methodParams | ||
69 | {-# INLINE methodQueryScheme #-} | ||
70 | |||
71 | newtype KResponseScheme = KResponseScheme | ||
72 | { rscVals :: [ValName] | ||
73 | } deriving (Show, Read, Eq, Ord) | ||
74 | |||
75 | instance KMessage KResponse KResponseScheme where | ||
76 | {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-} | ||
77 | scheme = KResponseScheme . bdictKeys . respVals | ||
78 | {-# INLINE scheme #-} | ||
79 | |||
80 | methodRespScheme :: Method a b -> KResponseScheme | ||
81 | methodRespScheme = KResponseScheme . methodVals | ||
82 | {-# INLINE methodRespScheme #-} | ||