1 files changed, 90 insertions, 0 deletions

diff --git a/Presence/AdaptServer.hs b/Presence/AdaptServer.hs
new file mode 100644
index 00000000..da3ab523
--- /dev/null
+++ b/Presence/AdaptServer.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module AdaptServer where
+
+import Data.IORef
+import Debug.Trace
+import Data.HList
+import Network.Socket (Socket)
+import qualified Data.ByteString.Lazy.Char8 as L
+import ByteStringOperators
+
+adaptStartCon start sock st = do
+    rsRef <- newIORef ""
+    st' <- start sock st
+    return (HCons rsRef st')
+
+adaptDoCon (dropTill,lex,parse) g st bs cont = do
+    putStrLn $ "packet: " ++ show bs
+    let (HCons rsRef st') = st
+    rs <- readIORef rsRef
+    {- parse error 
+     - ( "Expected <? but found <\n  in file remote-inbound  at line 1 col 1"
+     - , Chunk "<presence from='" Empty ,
+     -
+     - [(file remote-inbound  at line 1 col 1 ,<)
+     - ,(file remote-inbound  at line 1 col 2 ,presence)
+     - ,(file remote-inbound  at line 1 col 11 ,from)
+     - ,(file remote-inbound  at line 1 col 15 ,=)
+     - ,(file remote-inbound  at line 1 col 16 ,' or ")
+     - ,(file remote-inbound  at line 1 col 17 ,Lexical error:
+     -   unexpected EOF while looking for closing token '
+     -     to match the opening token in file remote-inbound  at line 1 col 17)
+     - ]
+     -
+     - )
+     -}
+    -- rs' =
+    -- ,[(file remote-inbound  at line 1 col 2 ,presence)
+    -- ,(file remote-inbound  at line 1 col 11 ,from)
+    -- ,(file remote-inbound  at line 1 col 15 ,=)
+    -- ,(file remote-inbound  at line 1 col 16 ,' or ")
+    -- ,(file remote-inbound  at line 1 col 17 ,Lexical error:
+    --   unexpected EOF while looking for closing token '
+    --   to match the opening token in file remote-inbound  at line 1 col 17)
+    -- ]
+    -- )
+    -- let parse' ls = let (e,rs') = parse ls
+
+    {- parse error ("Expected <? but found <\n  in file remote-inbound  at line 1 col 1"
+     - ,Chunk "<presence from='" Empty
+     - ,[(file remote-inbound  at line 1 col 1 ,<)
+     - ,(file remote-inbound  at line 1 col 2 ,presence)
+     - ,(file remote-inbound  at line 1 col 11 ,from)
+     - ,(file remote-inbound  at line 1 col 15 ,=)
+     - ,(file remote-inbound  at line 1 col 16 ,' or ")]
+     - ,[(file remote-inbound  at line 1 col 2 ,presence)
+     - ,(file remote-inbound  at line 1 col 11 ,from)
+     - ,(file remote-inbound  at line 1 col 15 ,=)
+     - ,(file remote-inbound  at line 1 col 16 ,' or ")])
+     -}
+
+    let contR rem v = do
+            writeIORef rsRef rem
+            cont v
+    let loop rem lexemes@(_:_) = do
+          let (e,rs') = parse lexemes
+          case e of
+              Left err -> if null rs'
+                            then contR "" ()
+                            else trace ("parse error "++show (err,bs,lexemes,rs')) $ do
+                                    contR rem ()
+              Right e -> do
+                -- writeIORef rsRef rs'
+                g st' e (\() -> loop (dropTill rem rs') rs')
+        loop rem [] = contR "" ()
+    let buf = rs <++> bs
+    when (L.length buf < 4096)
+         (loop buf (lex buf))
+
+{-
+adaptServer ::
+  (Show err, Show raw,Show lexemes)
+    =>
+      (raw -> [lexemes], [lexemes] -> (Either err msg, [lexemes]))
+      -> (Socket -> st -> IO st', 
+          st' -> msg -> (()->IO ()) -> IO ())
+      -> (Socket -> st -> IO (HCons (IORef [lexemes]) st'),
+          HCons (IORef [lexemes]) st' -> raw -> (()->IO ()) -> IO ())
+-}
+adaptServer (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon (dropTill,lex,parse) doCon)