module Serve where
import Control.Concurrent (forkIO)
import Control.Exception (bracket, finally)
import Control.Proxy (Pipe, ProxyFast, Server, Client, (>->), (<-<), runProxy)
import Control.Proxy.Trans (liftP)
import Control.Proxy.Trans.State (StateP, evalStateK)
import Control.Monad (forever)
import Data.ByteString (ByteString, empty)
import Network (listenOn, socketReader, socketWriter)
import Network.Socket (Socket, SockAddr, accept, sClose)
import Request (pipeBody, parseRequest)
import Response (responseWriter)
import Types (Request, Response)
type Handler m = (Request -> Pipe ProxyFast ByteString ByteString m (Response m))
serve :: Int
-> Handler IO
-> IO ()
serve port handler =
bracket (listenOn port) sClose $ \listenSocket ->
serveSocket listenSocket handler
serveSocket :: Socket
-> Handler IO
-> IO ()
serveSocket listenSocket handler =
forever $
do (sock, addr) <- accept listenSocket
let reader = socketReader sock
writer = socketWriter sock
forkIO $ (requestLoop False addr reader writer handler) `finally` (sClose sock)
requestLoop :: Bool
-> SockAddr
-> (() -> Server ProxyFast () ByteString IO ())
-> (() -> Client ProxyFast () ByteString IO ())
-> Handler IO
-> IO ()
requestLoop secure addr reader writer handler =
runProxy $ reader >-> (evalStateK empty $ httpPipe secure addr handler) >-> writer
httpPipe :: Bool
-> SockAddr
-> Handler IO
-> ()
-> StateP ByteString ProxyFast () ByteString () ByteString IO b
httpPipe secure addr handler () =
forever $
do request <- parseRequest secure addr
response <- ((liftP . (const $ handler request)) <-< pipeBody request) ()
liftP $ responseWriter (response :: Response IO)
return ()