blob: 2ef070388a0e8842e3441e2479483975cdf81657 (
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 (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,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 < 8192)
(loop buf (lex buf))
adaptServer (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon (dropTill,lex,parse) doCon)
|