blob: 3b57266c79b1f7dfe28f4007100faa6da0f8957f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
{-# 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 showlex (dropTill,lex,parse) g st bs cont = do
putStrLn $ "packet: " ++ show bs
let (HCons rsRef st') = st
rs <- readIORef rsRef
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,showlex lexemes,showlex rs')) $ do
contR rem ()
Right e -> do
-- writeIORef rsRef rs'
g st' e (\() -> do { putStrLn ("LOOP "++showlex rs'); loop (dropTill rem rs') rs' })
loop rem [] = contR "" ()
let buf = rs <++> bs
when (L.length buf < 8192)
(loop buf (lex buf))
adaptServer showlex (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon showlex (dropTill,lex,parse) doCon)
|
