First working test.

Ilya V. Portnov [2010-04-21 10:35:38]
First working test.
Filename
Server.hs
Test.hs
YAML.hs
YAMLInstances.hs
diff --git a/Server.hs b/Server.hs
new file mode 100644
index 0000000..01780ef
--- /dev/null
+++ b/Server.hs
@@ -0,0 +1,52 @@
+
+module Server where
+
+import Control.Monad
+import Control.Monad.State
+import Control.Concurrent
+import Control.Exception
+import Network
+import System.IO
+import qualified Data.ByteString.Char8 as BS
+import Data.Object.Yaml
+
+import YAML
+import YAMLInstances
+
+(<+>) = BS.append
+
+read' :: Handle -> [BS.ByteString] -> IO [BS.ByteString]
+read' h acc = do
+    line <- BS.hGetLine h
+    let line' = if (BS.last line)=='\r'
+                  then BS.init line
+                  else line
+--           print $ "read line:"++line'
+    if BS.null line'
+      then return acc
+      else read' h (acc ++ [line'])
+
+server ::
+      Int
+   -> (YamlObject -> IO YamlObject)
+   -> IO ()
+server port callOut = do
+--        installHandler sigPIPE Ignore Nothing
+      sock  <- listenOn (PortNumber $ fromIntegral port)
+      (forever $ loop sock) `finally` sClose sock
+  where
+    loop :: Socket -> IO ThreadId
+    loop sock =
+         do (h,_nm,_port) <- accept sock
+            forkIO
+              (do
+                lns <- read' h []
+                let text = BS.unlines lns
+                case unserialize text of
+                  Nothing -> hClose h
+                  Just ob -> do
+                    print ob
+                    res <- callOut ob
+                    BS.hPutStr h $ serialize res
+                    hClose h)
+
diff --git a/Test.hs b/Test.hs
new file mode 100644
index 0000000..aeab1e3
--- /dev/null
+++ b/Test.hs
@@ -0,0 +1,17 @@
+
+import Data.Object.Yaml
+import Data.Convertible.Base
+
+import Server
+import YAML
+import YAMLInstances
+
+worker :: YamlObject -> IO YamlObject
+worker obj = do
+  let (Point x y) = cs obj
+  return $ cs $ Point (x*2) (y*2)
+
+main = do
+  print "Listening..."
+  server 5000 worker
+  return ()
diff --git a/YAML.hs b/YAML.hs
index a89e064..e7c75be 100644
--- a/YAML.hs
+++ b/YAML.hs
@@ -4,11 +4,11 @@ module YAML where

 import Control.Monad
 import Data.Maybe
-import Data.Convertible
+-- import Data.Convertible
 import Data.Object
 import Data.Object.Yaml
 import qualified Data.ByteString.Char8 as BS
-import Text.Libyaml hiding (encode)
+import Text.Libyaml hiding (encode, decode)

 class (ConvertSuccess YamlObject a, ConvertSuccess a YamlObject) => IsYamlObject a where

@@ -37,13 +37,21 @@ serialize x =
       c = cs x
   in  encode c

-p = Point 3.0 2.0
-
-main = do
-  let s = serialize p
-  BS.putStrLn s
-  let c :: YamlObject
-      c = cs p
-      p' :: Point
-      p' = cs c
-  print p'
+unserialize :: IsYamlObject a => BS.ByteString -> Maybe a
+unserialize x =
+  let d :: Maybe YamlObject
+      d = decode x
+  in  case d of
+        Just y -> Just $ cs y
+        Nothing -> Nothing
+
+-- p = Point 3.0 2.0
+--
+-- main = do
+--   let s = serialize p
+--   BS.putStrLn s
+--   let c :: YamlObject
+--       c = cs p
+--       p' :: Point
+--       p' = cs c
+--   print p'
diff --git a/YAMLInstances.hs b/YAMLInstances.hs
index a513bd6..6b8be4f 100644
--- a/YAMLInstances.hs
+++ b/YAMLInstances.hs
@@ -1,6 +1,12 @@
+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}

 module YAMLInstances where

+import Data.Maybe
+-- import Data.Convertible
+import Data.Object
+import Data.Object.Yaml
+
 import YAML

 data Point = Point { x :: Double, y :: Double }
@@ -18,3 +24,5 @@ instance ConvertSuccess YamlObject Point where

 instance IsYamlObject Point where

+instance IsYamlObject YamlObject where
+
ViewGit