summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--krpc.cabal1
-rw-r--r--src/Remote/KRPC/Protocol.hs2
-rw-r--r--src/Remote/KRPC/Scheme.hs68
3 files changed, 70 insertions, 1 deletions
diff --git a/krpc.cabal b/krpc.cabal
index 446c612d..474778ad 100644
--- a/krpc.cabal
+++ b/krpc.cabal
@@ -22,6 +22,7 @@ source-repository head
22library 22library
23 exposed-modules: Remote.KRPC 23 exposed-modules: Remote.KRPC
24 , Remote.KRPC.Protocol 24 , Remote.KRPC.Protocol
25 , Remote.KRPC.Scheme
25 26
26 build-depends: base == 4.* 27 build-depends: base == 4.*
27 28
diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs
index 3f3b16d0..36a1e38a 100644
--- a/src/Remote/KRPC/Protocol.hs
+++ b/src/Remote/KRPC/Protocol.hs
@@ -19,7 +19,7 @@ module Remote.KRPC.Protocol
19 ( 19 (
20 20
21 -- * Error 21 -- * Error
22 KError(..), errorCode, mkKError 22 KError(..), ErrorCode, errorCode, mkKError
23 23
24 -- * Query 24 -- * Query
25 , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery 25 , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery
diff --git a/src/Remote/KRPC/Scheme.hs b/src/Remote/KRPC/Scheme.hs
new file mode 100644
index 00000000..84982649
--- /dev/null
+++ b/src/Remote/KRPC/Scheme.hs
@@ -0,0 +1,68 @@
1-- |
2-- Copyright : (c) Sam T. 2013
3-- License : MIT
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 use 'Remote.KRPC')
11-- this module seems to be useless.
12--
13{-# LANGUAGE DefaultSignatures #-}
14{-# LANGUAGE TypeSynonymInstances #-}
15{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
16module Remote.KRPC.Scheme
17 ( KMessage(..)
18 , KQueryScheme(..)
19 , KResponseScheme(..)
20 ) where
21
22import Data.Map as M
23import Data.Set
24
25import Remote.KRPC.Protocol
26
27
28-- | Used to validate any message by its scheme
29--
30-- forall m. m `validate` scheme m
31--
32class KMessage message scheme | message -> scheme where
33 -- | Get a message scheme.
34 scheme :: message -> scheme
35
36 -- | Check a message with a scheme.
37 validate :: message -> scheme -> Bool
38
39 default validate :: Eq scheme => message -> scheme -> Bool
40 validate = (==) . scheme
41 {-# INLINE validate #-}
42
43
44instance KMessage KError ErrorCode where
45 {-# SPECIALIZE instance KMessage KError ErrorCode #-}
46 scheme = errorCode
47 {-# INLINE scheme #-}
48
49
50data KQueryScheme = KQueryScheme {
51 qscMethod :: MethodName
52 , qscParams :: Set ParamName
53 } deriving (Show, Read, Eq, Ord)
54
55instance KMessage KQuery KQueryScheme where
56 {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-}
57 scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q))
58 {-# INLINE scheme #-}
59
60
61newtype KResponseScheme = KResponseScheme {
62 rscVals :: Set ValName
63 } deriving (Show, Read, Eq, Ord)
64
65instance KMessage KResponse KResponseScheme where
66 {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-}
67 scheme = KResponseScheme . keysSet . respVals
68 {-# INLINE scheme #-} \ No newline at end of file