summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--krpc.cabal1
-rw-r--r--src/Network/KRPC.hs2
-rw-r--r--src/Network/KRPC/Scheme.hs82
3 files changed, 1 insertions, 84 deletions
diff --git a/krpc.cabal b/krpc.cabal
index 43c4b5f0..e44f5d90 100644
--- a/krpc.cabal
+++ b/krpc.cabal
@@ -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--
336server :: (MonadBaseControl IO remote, MonadIO remote) 336server :: (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 ()
340server servAddr handlers = do 340server 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 #-}
17module Network.KRPC.Scheme
18 ( KMessage(..)
19 , KQueryScheme(..), methodQueryScheme
20 , KResponseScheme(..), methodRespScheme
21 ) where
22
23import Control.Applicative
24import Data.BEncode.BDict as BS
25import Data.BEncode.Types as BS
26
27import Network.KRPC.Protocol
28import Network.KRPC
29
30
31-- | Used to validate any message by its scheme
32--
33-- forall m. m `validate` scheme m
34--
35class 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
47instance KMessage KError ErrorCode where
48 scheme = errorCode
49 {-# INLINE scheme #-}
50
51data KQueryScheme = KQueryScheme {
52 qscMethod :: MethodName
53 , qscParams :: [ParamName]
54 } deriving (Show, Read, Eq, Ord)
55
56bdictKeys :: BDict -> [BKey]
57bdictKeys (Cons k _ xs) = k : bdictKeys xs
58bdictKeys Nil = []
59
60instance KMessage KQuery KQueryScheme where
61 scheme q = KQueryScheme
62 { qscMethod = queryMethod q
63 , qscParams = bdictKeys $ queryArgs q
64 }
65 {-# INLINE scheme #-}
66
67methodQueryScheme :: Method a b -> KQueryScheme
68methodQueryScheme = KQueryScheme <$> methodName <*> methodParams
69{-# INLINE methodQueryScheme #-}
70
71newtype KResponseScheme = KResponseScheme
72 { rscVals :: [ValName]
73 } deriving (Show, Read, Eq, Ord)
74
75instance KMessage KResponse KResponseScheme where
76 {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-}
77 scheme = KResponseScheme . bdictKeys . respVals
78 {-# INLINE scheme #-}
79
80methodRespScheme :: Method a b -> KResponseScheme
81methodRespScheme = KResponseScheme . methodVals
82{-# INLINE methodRespScheme #-}