blob: dd453ba95c214734c8390277b3a4090ff891f9b4 (
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)
|
