diff options
Diffstat (limited to 'Presence/AdaptServer.hs')
-rw-r--r-- | Presence/AdaptServer.hs | 40 |
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 #-} | ||
3 | module AdaptServer where | ||
4 | |||
5 | import Data.IORef | ||
6 | import Data.HList | ||
7 | -- import Network.Socket (Socket) | ||
8 | import qualified Data.ByteString.Lazy.Char8 as L | ||
9 | import ByteStringOperators | ||
10 | |||
11 | adaptStartCon start sock st = do | ||
12 | rsRef <- newIORef "" | ||
13 | st' <- start sock st | ||
14 | return (HCons rsRef st') | ||
15 | |||
16 | adaptDoCon 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 | |||
40 | adaptServer showlex (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon showlex (dropTill,lex,parse) doCon) | ||