Sketch of http server implementation based on pipes

http.hs

import Control.Monad
import Control.Pipe
import Control.Pipe.ChunkPipe
import Control.Pipe.Monoidal
import Data.ByteString (ByteString, empty)
import Data.List
import Data.Void
import Network.Socket

type Input = Either RequestH ByteString
type TInput = Either RequestH (Maybe ByteString)
type Output = Either ResponseH ByteString
type Handler m = RequestH -> Pipe ByteString Output m ()

server :: Monad m => Handler m -> Pipe ByteString ByteString m ()
server handler =
  rqParser >+>
  secondP regularize >+>
  rqDispatcher handler >+>
  respWriter

regularize :: Monad m => Pipe ByteString (Maybe ByteString) m r
regularize = forever $ do
  chunk <- await
  let cs = splitChunk
  sequence_ $ intersperse (yield Nothing)
                          (map (yield . Just) cs)

rqParser :: Monad m => Pipe ByteString (Either RequestH ByteString) m r
rqParser = fmap snd . unChunkPipe . forever . chunkPipe_ $ tryParseHeader

tryParseHeader :: Monad m
               => Pipe ByteString
                       Input
                       m ByteString
tryParseHeader = do
  x <- await
  if isHeaderStart x
    then {- ... -} yield (Left RequestH) >> return leftover
    else yield (Right x) >> return empty

chunkPipe_ :: Monad m => Pipe a b m a -> ChunkPipe a b m ()
chunkPipe_ p = ChunkPipe $ fmap (\l -> (l, ())) p

rqDispatcher :: Monad m
             => Handler m
             -> Pipe TInput Output m r
rqDispatcher handler =
  addTerminators >+>
  sequencer handler >+>
  discardL

-- serialize responses
respWriter :: Monad m => Pipe Output ByteString m r
respWriter = undefined

-- add terminators to the byte stream whenever a new request arrives
addTerminators :: Monad m => Pipe TInput TInput m r
addTerminators = go True
  where
    go q = do
      x <- await
      case x of
        Left req -> do
          unless q $ yield (Right Nothing)
          yield (Left req)
          go True
        Right chunk -> do
          yield $ Right chunk
          go False

-- enqueue handlers when a new request arrives
sequencer :: Monad m
          => Handler m
          -> Pipe TInput
                  (Either (Maybe ByteString) Output)
                  m r
sequencer handler = do
  x <- await
  case x of
    Left req -> sequencer handler >+> linearize (handler req)
    Right chunk -> yield (Left chunk) >> sequencer handler

-- modify consumer so that it can be used in a stream with explicit
-- terminators, and composed with other consumers
linearize :: Monad m
          => Pipe a b m r'
          -> Pipe (Either (Maybe a) b)
                  (Either (Maybe a) b) m r
linearize p = do
  firstP (stoppable >+> (p >> discard)) >+> joinP >+> pipe Right
  idP

-- generally useful combinator which I could include in pipes-extra
stoppable :: Monad m => Pipe (Maybe a) a m (Maybe r)
stoppable = await >>= maybe (return Nothing) (\x -> yield x >> stoppable)

-- to make the file typecheckable
data RequestH = RequestH
data ResponseH = ResponseH
leftover = undefined
isHeaderStart = undefined
splitChunk = undefined