summaryrefslogtreecommitdiff
path: root/Presence/AdaptServer.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/AdaptServer.hs')
-rw-r--r--Presence/AdaptServer.hs59
1 files changed, 5 insertions, 54 deletions
diff --git a/Presence/AdaptServer.hs b/Presence/AdaptServer.hs
index da3ab523..2ef07038 100644
--- a/Presence/AdaptServer.hs
+++ b/Presence/AdaptServer.hs
@@ -3,9 +3,9 @@
3module AdaptServer where 3module AdaptServer where
4 4
5import Data.IORef 5import Data.IORef
6import Debug.Trace 6-- import Debug.Trace
7import Data.HList 7import Data.HList
8import Network.Socket (Socket) 8-- import Network.Socket (Socket)
9import qualified Data.ByteString.Lazy.Char8 as L 9import qualified Data.ByteString.Lazy.Char8 as L
10import ByteStringOperators 10import ByteStringOperators
11 11
@@ -18,46 +18,6 @@ adaptDoCon (dropTill,lex,parse) g st bs cont = do
18 putStrLn $ "packet: " ++ show bs 18 putStrLn $ "packet: " ++ show bs
19 let (HCons rsRef st') = st 19 let (HCons rsRef st') = st
20 rs <- readIORef rsRef 20 rs <- readIORef rsRef
21 {- parse error
22 - ( "Expected <? but found <\n in file remote-inbound at line 1 col 1"
23 - , Chunk "<presence from='" Empty ,
24 -
25 - [(file remote-inbound at line 1 col 1 ,<)
26 - ,(file remote-inbound at line 1 col 2 ,presence)
27 - ,(file remote-inbound at line 1 col 11 ,from)
28 - ,(file remote-inbound at line 1 col 15 ,=)
29 - ,(file remote-inbound at line 1 col 16 ,' or ")
30 - ,(file remote-inbound at line 1 col 17 ,Lexical error:
31 - unexpected EOF while looking for closing token '
32 - to match the opening token in file remote-inbound at line 1 col 17)
33 - ]
34 -
35 - )
36 -}
37 -- rs' =
38 -- ,[(file remote-inbound at line 1 col 2 ,presence)
39 -- ,(file remote-inbound at line 1 col 11 ,from)
40 -- ,(file remote-inbound at line 1 col 15 ,=)
41 -- ,(file remote-inbound at line 1 col 16 ,' or ")
42 -- ,(file remote-inbound at line 1 col 17 ,Lexical error:
43 -- unexpected EOF while looking for closing token '
44 -- to match the opening token in file remote-inbound at line 1 col 17)
45 -- ]
46 -- )
47 -- let parse' ls = let (e,rs') = parse ls
48
49 {- parse error ("Expected <? but found <\n in file remote-inbound at line 1 col 1"
50 - ,Chunk "<presence from='" Empty
51 - ,[(file remote-inbound at line 1 col 1 ,<)
52 - ,(file remote-inbound at line 1 col 2 ,presence)
53 - ,(file remote-inbound at line 1 col 11 ,from)
54 - ,(file remote-inbound at line 1 col 15 ,=)
55 - ,(file remote-inbound at line 1 col 16 ,' or ")]
56 - ,[(file remote-inbound at line 1 col 2 ,presence)
57 - ,(file remote-inbound at line 1 col 11 ,from)
58 - ,(file remote-inbound at line 1 col 15 ,=)
59 - ,(file remote-inbound at line 1 col 16 ,' or ")])
60 -}
61 21
62 let contR rem v = do 22 let contR rem v = do
63 writeIORef rsRef rem 23 writeIORef rsRef rem
@@ -67,24 +27,15 @@ adaptDoCon (dropTill,lex,parse) g st bs cont = do
67 case e of 27 case e of
68 Left err -> if null rs' 28 Left err -> if null rs'
69 then contR "" () 29 then contR "" ()
70 else trace ("parse error "++show (err,bs,lexemes,rs')) $ do 30 else -- trace ("parse error "++show (err,bs,lexemes,rs')) $ do
71 contR rem () 31 contR rem ()
72 Right e -> do 32 Right e -> do
73 -- writeIORef rsRef rs' 33 -- writeIORef rsRef rs'
74 g st' e (\() -> loop (dropTill rem rs') rs') 34 g st' e (\() -> loop (dropTill rem rs') rs')
75 loop rem [] = contR "" () 35 loop rem [] = contR "" ()
76 let buf = rs <++> bs 36 let buf = rs <++> bs
77 when (L.length buf < 4096) 37 when (L.length buf < 8192)
78 (loop buf (lex buf)) 38 (loop buf (lex buf))
79 39
80{- 40
81adaptServer ::
82 (Show err, Show raw,Show lexemes)
83 =>
84 (raw -> [lexemes], [lexemes] -> (Either err msg, [lexemes]))
85 -> (Socket -> st -> IO st',
86 st' -> msg -> (()->IO ()) -> IO ())
87 -> (Socket -> st -> IO (HCons (IORef [lexemes]) st'),
88 HCons (IORef [lexemes]) st' -> raw -> (()->IO ()) -> IO ())
89-}
90adaptServer (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon (dropTill,lex,parse) doCon) 41adaptServer (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon (dropTill,lex,parse) doCon)