acme-http-0.1: Acme/Serve.hs

module Acme.Serve where

import Acme.Request
import Acme.Response
import Acme.Types
import Control.Concurrent (killThread, forkIO)
import Control.Exception.Extensible             as E
import Control.Monad (forever)
import Control.Monad.Trans
import Data.ByteString                          (ByteString, empty)
import Data.ByteString.Char8                    (pack)
import Network.BSD                              (getProtocolNumber)
import Network.Socket                           (Socket, SockAddr(..), SocketOption(..), SocketType(Stream), Family(AF_INET), accept, bindSocket, iNADDR_ANY, sClose, listen, maxListenQueue, setSocketOption, socket)
import Network.Socket.ByteString                (recv, sendAll)
import System.IO



-- | start TCP listening on a port
listenOn :: Int  -- ^ port number
         -> IO Socket
listenOn portm = do
    proto <- getProtocolNumber "tcp"
    E.bracketOnError
        (socket AF_INET Stream proto)
        (sClose)
        (\sock -> do
            setSocketOption sock ReuseAddr 1
            setSocketOption sock NoDelay 1
            bindSocket sock (SockAddrInet (fromIntegral portm) iNADDR_ANY)
            listen sock (max 1024 maxListenQueue)
            return sock
        )

-- | listen on a port and handle 'Requests'
serve ::  Int                                -- ^ port to listen on
      -> (Request -> IO Response)  -- ^ request handler
      -> IO ()
serve port app =
    bracket (listenOn port) sClose $ \listenSocket ->
        serveSocket listenSocket app

-- | handle 'Requests' from an already listening 'Socket'
serveSocket :: Socket                             -- ^ 'Socket' in listen mode
            -> (Request -> IO Response) -- ^ request handler
            -> IO ()
serveSocket listenSocket app =
    forever $
        do (sock, addr) <- accept listenSocket
           let reader = recv sock 4096
               writer = sendAll sock
           forkIO $ do requestLoop False addr reader writer app `E.catch` (\ConnectionClosed -> return ())
                       sClose sock

requestLoop :: Bool
            -> SockAddr
            -> IO ByteString
            -> (ByteString -> IO ())
            -> (Request -> IO Response)
            -> IO ()
requestLoop secure addr reader writer app =
    go empty
    where
      go bs =
          do (request, bs') <- parseRequest reader bs secure
             pong writer
             go bs'
{-
    runPipe $ reader >+> httpPipe empty >+> writer
    where
      httpPipe :: ByteString -> Pipe ByteString ByteString (ResourceT IO) ()
      httpPipe bs =
          do (request, bs')  <- parseRequest bs secure
             response <- appPipe request
             responsePipe response
--             _remaining <- discardBody request
             httpPipe bs'

      discardBody :: Request -> Pipe ByteString ByteString (ResourceT IO) ByteString
      discardBody request = rqBody request >> discard

      appPipe :: Request -> Pipe ByteString ByteString (ResourceT IO) Response
      appPipe req = lift $ app req


hello :: Request -> ResourceT IO Response
hello req = 
    do lift $ print (ppRequest req)
       let res = Response { rsCode = 200
                          , rsBody = ResponsePipe $ return ()
                          }
       lift $ print (ppResponse res)
       return $ res
-}