Add methods dispatcher.

Ilya Portnov [2010-04-21 12:18:07]
Add methods dispatcher.
Filename
.gitignore
Dispatcher.hs
Test.hs
YAML.hs
YAMLInstances.hs
diff --git a/.gitignore b/.gitignore
index 1422057..67d6822 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,2 +1,4 @@
 *.hi
 *.o
+*.swp
+
diff --git a/Dispatcher.hs b/Dispatcher.hs
new file mode 100644
index 0000000..0835865
--- /dev/null
+++ b/Dispatcher.hs
@@ -0,0 +1,28 @@
+
+module Dispatcher where
+
+import qualified Data.Map as M
+import Data.Object.Yaml
+import Data.Convertible.Base
+import qualified Data.ByteString.Char8 as BS
+
+import YAML
+import YAMLInstances
+import Server
+
+type Worker = YamlObject -> IO YamlObject
+type Rules = M.Map BS.ByteString Worker
+
+mkRules :: [(String,Worker)] -> Rules
+mkRules pairs = M.fromList [(BS.pack name, worker) | (name,worker) <- pairs]
+
+dispatch :: Rules -> (YamlObject -> IO YamlObject)
+dispatch rules obj = do
+  let call :: Call
+      call = cs obj
+  case M.lookup (methodName call) rules of
+    Nothing -> fail $ "Unknown method: " ++ (BS.unpack $ methodName call)
+    Just fn -> fn (args call)
+
+dispatcher :: Int -> Rules -> IO ()
+dispatcher port rules = server port (dispatch rules)
diff --git a/Test.hs b/Test.hs
index aeab1e3..ea45905 100644
--- a/Test.hs
+++ b/Test.hs
@@ -1,17 +1,20 @@

 import Data.Object.Yaml
 import Data.Convertible.Base
+import qualified Data.Map as M

-import Server
+import Dispatcher
 import YAML
 import YAMLInstances

-worker :: YamlObject -> IO YamlObject
-worker obj = do
+double :: YamlObject -> IO YamlObject
+double obj = do
   let (Point x y) = cs obj
   return $ cs $ Point (x*2) (y*2)

+rules = mkRules [("double", double)]
+
 main = do
-  print "Listening..."
-  server 5000 worker
+  putStrLn "Listening..."
+  dispatcher 5000 rules
   return ()
diff --git a/YAML.hs b/YAML.hs
index e7c75be..10fbd1b 100644
--- a/YAML.hs
+++ b/YAML.hs
@@ -24,9 +24,19 @@ getScalar :: (IsYamlScalar a) => YamlObject -> Maybe a
 getScalar (Scalar x) = Just (fromYamlScalar x)
 getScalar _          = Nothing

+getList :: YamlObject -> [YamlObject]
+getList (Sequence lst) = lst
+getList _              = []
+
 getScalarAttr :: (IsYamlScalar a) => String -> YamlObject -> Maybe a
 getScalarAttr key obj = getScalar =<< getAttr key obj

+getListAttr :: String -> YamlObject -> [YamlObject]
+getListAttr key obj =
+  case getAttr key obj of
+    Just x -> getList x
+    Nothing -> []
+
 instance IsYamlScalar Double where
   fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v
   toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any
diff --git a/YAMLInstances.hs b/YAMLInstances.hs
index 6b8be4f..676135a 100644
--- a/YAMLInstances.hs
+++ b/YAMLInstances.hs
@@ -3,18 +3,34 @@
 module YAMLInstances where

 import Data.Maybe
--- import Data.Convertible
 import Data.Object
 import Data.Object.Yaml
+import qualified Data.ByteString.Char8 as BS

 import YAML

 data Point = Point { x :: Double, y :: Double }
   deriving (Show)

+object :: [(String, YamlScalar)] -> YamlObject
+object pairs = Mapping [(toYamlScalar name, Scalar val) | (name,val) <- pairs]
+
+field :: (IsYamlScalar a) => String -> a -> YamlObject
+field name val = Mapping [(toYamlScalar name, Scalar $ toYamlScalar val)]
+
+instance (IsYamlObject a) => ConvertSuccess [a] YamlObject where
+  convertSuccess lst = Sequence $ map cs lst
+
+instance (IsYamlObject a) => ConvertSuccess YamlObject [a] where
+  convertSuccess (Mapping pairs) = map cs $ map snd pairs
+  convertSuccess (Sequence lst) = map cs lst
+  convertSuccess s@(Scalar _) = [cs s]
+
+instance (IsYamlObject a) => IsYamlObject [a] where
+
 instance ConvertSuccess Point YamlObject where
-  convertSuccess (Point x y) = Mapping [(toYamlScalar "x", Scalar $ toYamlScalar x),
-                                        (toYamlScalar "y", Scalar $ toYamlScalar y)]
+  convertSuccess (Point x y) = object [("x", toYamlScalar x),
+                                       ("y", toYamlScalar y)]

 instance ConvertSuccess YamlObject Point where
   convertSuccess obj = Point x y
@@ -26,3 +42,21 @@ instance IsYamlObject Point where

 instance IsYamlObject YamlObject where

+data Call = Call { methodName :: BS.ByteString, args :: YamlObject }
+  deriving (Show)
+
+call :: String -> YamlObject -> YamlObject
+call name args = cs $ Call (BS.pack name) args
+
+instance ConvertSuccess Call YamlObject where
+  convertSuccess (Call name args) = Mapping [(toYamlScalar "call", Scalar $ toYamlScalar name),
+                                             (toYamlScalar "args", args)]
+
+instance ConvertSuccess YamlObject Call where
+  convertSuccess obj = Call name args
+    where
+      name = fromMaybe (BS.pack "defaultMethod") $ getScalarAttr "call" obj
+      args = fromMaybe (Sequence []) $ getAttr "args" obj
+
+instance IsYamlObject Call where
+
ViewGit