~ Prepare to scheme check.

3 files changed, 64 insertions, 29 deletions

diff --git a/src/Remote/KRPC.hs b/src/Remote/KRPC.hs
index 8f2027f2..22dbf3aa 100644
--- a/src/Remote/KRPC.hs
+++ b/src/Remote/KRPC.hs
@@ -10,6 +10,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-}
 {-# LANGUAGE ExplicitForAll, KindSignatures #-}
+{-# LANGUAGE ViewPatterns #-}
 module Remote.KRPC
        ( module Remote.KRPC.Method, RemoteAddr
 
@@ -17,7 +18,7 @@ module Remote.KRPC
        , call, async, await
 
          -- * Server
-       , server
+       , (==>), server
        ) where
 
 import Control.Exception
@@ -27,6 +28,7 @@ import Control.Monad.IO.Class
 import Data.BEncode
 import Data.List as L
 import Data.Map  as M
+import Data.Set  as S
 import Data.Text as T
 import Data.Typeable
 import Network
@@ -51,6 +53,7 @@ queryCall sock addr m arg = sendMessage q addr sock
   where
     q = kquery (L.head (methodName m)) [(L.head (methodParams m), toBEncode arg)]
 
+-- TODO check scheme
 getResult :: BEncodable result
           => KRemote -> KRemoteAddr
           -> Method param result -> IO result
@@ -58,7 +61,7 @@ getResult sock addr m = do
   resp <- recvResponse addr sock
   case resp of
     Left e -> throw (RPCException e)
-    Right (KResponse dict) -> do
+    Right (respVals -> dict) -> do
       let valName = L.head (methodVals m)
       case M.lookup valName dict of
         Just val | Right res <- fromBEncode val -> return res
@@ -102,10 +105,10 @@ async addr m arg = do
 await :: MonadIO host => Async result -> host result
 await = liftIO . waitResult
 
--- TODO better name
-type MHandler remote = ( Method BEncode (Result BEncode)
-                       , BEncode -> remote (Result BEncode)
-                       )
+type HandlerBody remote = (BEncode -> remote (Result BEncode), KResponseScheme)
+
+type MethodHandler remote = (KQueryScheme, HandlerBody remote)
+
 
 -- we can safely erase types in (==>)
 (==>) :: forall (remote :: * -> *) (param :: *) (result :: *).
@@ -113,8 +116,8 @@ type MHandler remote = ( Method BEncode (Result BEncode)
         => Monad remote
         => Method param result
         -> (param -> remote result)
-        -> MHandler remote
-m ==> body = undefined
+        -> MethodHandler remote
+m ==> body = (methodQueryScheme m, (newbody, methodRespScheme m))
   where
     newbody x = case fromBEncode x of
                     Right a -> liftM (Right . toBEncode) (body a)
@@ -125,15 +128,28 @@ m ==> body = undefined
 -- TODO: allow overloading
 server :: (MonadBaseControl IO remote, MonadIO remote)
        => PortNumber
-       -> [MHandler remote]
+       -> [MethodHandler remote]
        -> remote ()
-server servport ms = remoteServer servport $ \_ q -> do
-  let name = queryMethod q
-  let args = undefined -- queryArgs q
-  let m = L.head ms
-  res <- undefined -- methodBody m (snd (L.head (M.toList args)))
-  case res of
-   Left  r -> return (Left (ProtocolError (T.pack r)))
-   Right r -> do
-     let retName = undefined -- L.head (methodVals m)
-     return (Right (kresponse [(retName, r)]))
+server servport handlers = do
+    remoteServer servport $ \_ q -> do
+      case dispatch (scheme q) of
+        Nothing -> return (Left (MethodUnknown "method"))
+        Just (m, rsc) -> do
+          let arg = snd (L.head (M.toList (queryArgs q)))
+
+          res <- invoke m arg
+          let valName = L.head (S.toList (rscVals rsc))
+          return $ bimap (ProtocolError . T.pack)
+                         (kresponse . return .  (,) valName) res
+  where
+    handlerMap = M.fromList handlers
+
+--    dispatch :: KQueryScheme -> MethodHandler remote
+    dispatch s | Just m <-  M.lookup s handlerMap = return m
+               | otherwise                        = Nothing
+
+--    invoke :: MethodHandler remote -> BEncode -> remote BEncode
+    invoke m args = m args
+
+    bimap f _ (Left  x) = Left (f x)
+    bimap _ g (Right x) = Right (g x)
\ No newline at end of file
diff --git a/src/Remote/KRPC/Method.hs b/src/Remote/KRPC/Method.hs
index 3c757d07..420ceacf 100644
--- a/src/Remote/KRPC/Method.hs
+++ b/src/Remote/KRPC/Method.hs
@@ -1,6 +1,14 @@
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  portable
+--
 {-# LANGUAGE OverloadedStrings #-}
 module Remote.KRPC.Method
        ( Method(methodName, methodParams, methodVals)
+       , methodQueryScheme, methodRespScheme
 
          -- * Construction
        , method
@@ -10,13 +18,16 @@ module Remote.KRPC.Method
        ) where
 
 import Prelude hiding ((.), id)
+import Control.Applicative
 import Control.Category
 import Control.Monad
+import Data.ByteString as B
+import Data.List as L
+import Data.Set as S
 
 import Remote.KRPC.Protocol
 
 
-
 -- | The
 --
 --   * argument: type of method parameter
@@ -44,6 +55,15 @@ instance Category Method where
   (.) = composeM
   {-# INLINE (.) #-}
 
+methodQueryScheme :: Method a b -> KQueryScheme
+methodQueryScheme = KQueryScheme <$> B.intercalate "." . methodName
+                                 <*> S.fromList . methodParams
+{-# INLINE methodQueryScheme #-}
+
+
+methodRespScheme :: Method a b -> KResponseScheme
+methodRespScheme = KResponseScheme . S.fromList . methodVals
+{-# INLINE methodRespScheme #-}
 
 -- TODO ppMethod
 
diff --git a/src/Remote/KRPC/Protocol.hs b/src/Remote/KRPC/Protocol.hs
index e7fbea11..625aba25 100644
--- a/src/Remote/KRPC/Protocol.hs
+++ b/src/Remote/KRPC/Protocol.hs
@@ -24,12 +24,12 @@ module Remote.KRPC.Protocol
        , KError(..), errorCode, mkKError
 
          -- * Query
-       , KQuery(queryMethod, queryParams), MethodName, ParamName, kquery
-       , KQueryScheme(qscMethod, qscParams)
+       , KQuery(queryMethod, queryArgs), MethodName, ParamName, kquery
+       , KQueryScheme(KQueryScheme, qscMethod, qscParams)
 
          -- * Response
        , KResponse(respVals), ValName, kresponse
-       , KResponseScheme(rscVals)
+       , KResponseScheme(KResponseScheme, rscVals)
 
        , sendMessage, recvResponse
 
@@ -46,12 +46,14 @@ import Control.Exception.Lifted
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Control
+
 import Data.BEncode
 import Data.ByteString as B
 import qualified Data.ByteString.Lazy as LB
 import Data.Map as M
 import Data.Set as S
 import Data.Text as T
+
 import Network.Socket hiding (recvFrom)
 import Network.Socket.ByteString
 
@@ -134,7 +136,7 @@ type ParamName  = ByteString
 -- TODO document that it is and how transferred
 data KQuery = KQuery {
     queryMethod :: MethodName
-  , queryParams :: Map ParamName BEncode
+  , queryArgs   :: Map ParamName BEncode
   } deriving (Show, Read, Eq, Ord)
 
 instance BEncodable KQuery where
@@ -160,12 +162,9 @@ data KQueryScheme = KQueryScheme {
   , qscParams :: Set ParamName
   } deriving (Show, Read, Eq, Ord)
 
-domen :: Map a b -> Set a
-domen = error "scheme.domen"
-
 instance KMessage KQuery KQueryScheme where
   {-# SPECIALIZE instance KMessage KQuery KQueryScheme #-}
-  scheme q = KQueryScheme (queryMethod q) (domen (queryParams q))
+  scheme q = KQueryScheme (queryMethod q) (M.keysSet (queryArgs q))
   {-# INLINE scheme #-}
 
 type ValName = ByteString
@@ -198,7 +197,7 @@ newtype KResponseScheme = KResponseScheme {
 
 instance KMessage KResponse KResponseScheme where
   {-# SPECIALIZE instance KMessage KResponse KResponseScheme #-}
-  scheme = KResponseScheme . domen . respVals
+  scheme = KResponseScheme . keysSet . respVals
   {-# INLINE scheme #-}