Serve.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP.Pony.Serve where

import           Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Catch (MonadMask)
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Network.Socket as NS
import qualified Network.Socket.ByteString as NSB
import           Pipes (Effect, Producer, Consumer, runEffect, (>->), await)
import           Pipes.Network.TCP.Safe (HostPreference())
import           Pipes.Network.TCP.Safe (fromSocket, toSocket, connect, connectSock
                                        , closeSock)
import qualified Pipes.Network.TCP.Safe as PipesNetwork
import           Pipes.Safe (MonadSafe(), runSafeT, SafeT)

import           Network.HTTP.Pony.Helper ((-), shutdownSend, shutdownReceive)
import           Network.HTTP.Pony.ServeSafe (serveWithPipe)
import           Prelude hiding ((-), log)


serveWithSocket :: (MonadIO m)  => (NS.Socket, NS.SockAddr)
                                -> (Producer ByteString m () -> m (Producer ByteString m ()))
                                -> m ()
serveWithSocket (s,_) =
  let
    pull = fromSocket s 4096
    push = do
      x <- await
      -- liftIO (putStrLn ( "pony chunk: " ++ show (B.length x) ++ " - " ++ B.unpack x ))

      if B.null x
        then do
          -- liftIO (putStrLn "pony shutdone send")
          shutdownSend s
          () <$ await
        else do
          liftIO (NSB.send s x)
          push
  in

  serveWithPipe pull push

serveT :: (MonadSafe m, MonadMask n, MonadIO n)
               => (n () -> IO ())
               -> HostPreference
               -> NS.ServiceName
               -> (Producer ByteString (SafeT n) ()
                   -> (SafeT n) (Producer ByteString (SafeT n) ()))
               -> m ()
serveT exit host service app =
  PipesNetwork.serve host service - \socket -> do
    -- no-delay is specifically encouraged in HTTP/2
    -- https://http2.github.io/faq/#will-i-need-tcpnodelay-for-my-http2-connections
    liftIO - NS.setSocketOption (fst socket) NS.NoDelay 1

    exit - runSafeT (serveWithSocket socket app)


serve, run :: (MonadSafe m)  => HostPreference
                        -> NS.ServiceName
                        -> (Producer ByteString (SafeT IO) ()
                            -> (SafeT IO) (Producer ByteString (SafeT IO) ()))
                        -> m ()
serve = serveT id
run = serve