Add methods dispatcher.
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
+