summaryrefslogtreecommitdiff
path: root/Presence/AdaptServer.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/AdaptServer.hs')
-rw-r--r--Presence/AdaptServer.hs40
1 files changed, 0 insertions, 40 deletions
diff --git a/Presence/AdaptServer.hs b/Presence/AdaptServer.hs
deleted file mode 100644
index e4940331..00000000
--- a/Presence/AdaptServer.hs
+++ /dev/null
@@ -1,40 +0,0 @@
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AdaptServer where
4
5import Data.IORef
6import Data.HList
7-- import Network.Socket (Socket)
8import qualified Data.ByteString.Lazy.Char8 as L
9import ByteStringOperators
10
11adaptStartCon start sock st = do
12 rsRef <- newIORef ""
13 st' <- start sock st
14 return (HCons rsRef st')
15
16adaptDoCon showlex (dropTill,lex,parse) g st bs cont = do
17 putStrLn $ "packet: " ++ show bs
18 let (HCons rsRef st') = st
19 rs <- readIORef rsRef
20
21 let contR rem v = do
22 writeIORef rsRef rem
23 cont v
24 let loop rem lexemes@(_:_) = do
25 let (e,rs') = parse lexemes
26 case e of
27 Left err -> if null rs'
28 then contR "" ()
29 else -- trace ("parse error "++show (err,bs,showlex lexemes,showlex rs')) $ do
30 contR rem ()
31 Right e -> do
32 -- writeIORef rsRef rs'
33 g st' e (\() -> do { {- putStrLn ("LOOP "++showlex rs'); -} loop (dropTill rem rs') rs' })
34 loop rem [] = contR "" ()
35 let buf = rs <++> bs
36 when (L.length buf < 8192)
37 (loop buf (lex buf))
38
39
40adaptServer showlex (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon showlex (dropTill,lex,parse) doCon)