Serve.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP.Pony.Serve where

import           Prelude hiding ((-), log)

import           Control.Exception (IOException)
import qualified Control.Exception as E
import           Control.Monad.Catch (MonadCatch, MonadMask, finally, onException)
import           Control.Monad.IO.Class (MonadIO(..))
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import           Data.Monoid ((<>))
import qualified Network.Socket as NS
import qualified Network.Socket.ByteString as NSB
import           Pipes (Effect, Producer, Consumer, runEffect, (>->), await, yield)
import           Pipes.Network.TCP.Safe (HostPreference())
import           Pipes.Network.TCP.Safe (connect, connectSock, closeSock)
import           Pipes.Network.TCP.Safe (fromSocketTimeout, toSocketTimeout)
import qualified Pipes.Network.TCP.Safe as PipesNetwork
import           Pipes.Safe (MonadSafe(), runSafeT, SafeT, tryP, throwM)

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


defaultTimeout :: Int
defaultTimeout = 600

serveWithSocket :: (MonadSafe m, MonadCatch m)  =>
                                   (NS.Socket, NS.SockAddr)
                                -> (Producer ByteString m () -> m (Producer ByteString m ()))
                                -> m ()
serveWithSocket = serveWithSocketTimeout defaultTimeout

serveWithSocketTimeout :: (MonadSafe m, MonadCatch m)  =>
                                   Int
                                -> (NS.Socket, NS.SockAddr)
                                -> (Producer ByteString m () -> m (Producer ByteString m ()))
                                -> m ()
serveWithSocketTimeout timeout (s,_) =
  let
    pull = do
      fromSocketTimeout (timeout * 1000000) s 4096

    push = toSocketTimeout (timeout * 1000000) s

    pushWithCallbackOnEmptyToShutdownSend = do
      x <- await

      if B.null x
        then do

          let cont = () <$ await
          r <- tryP (shutdownSend s)
          case r of
            Right _ -> cont
            Left e -> do

              cont

              throwM (e :: IOException)

        else do
          yield x
          pushWithCallbackOnEmptyToShutdownSend
  in

  let safePush =
        (
          pushWithCallbackOnEmptyToShutdownSend >-> push
        )
          `onException`
          (
            do
              -- These shutdowns strictly speaking are not nessorary.
              -- But on mac there is an obscure kevent error.
              -- These are hacks to reduce the chance of that error.

              shutdownSend s
              shutdownReceive s
          )
  in

  serveWithPipe pull safePush

serveT_Timeout :: (MonadSafe m, MonadMask n, MonadIO n)
               => Int
               -> (n () -> IO ())
               -> HostPreference
               -> NS.ServiceName
               -> (Producer ByteString (SafeT n) ()
                   -> (SafeT n) (Producer ByteString (SafeT n) ()))
               -> m ()
serveT_Timeout timeout 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 - do
      NS.setSocketOption (fst socket) NS.NoDelay 1

    exit - runSafeT (serveWithSocketTimeout timeout socket app)


serveT :: (MonadSafe m, MonadMask n, MonadIO n)
                        => (n () -> IO ())
                        -> HostPreference
                        -> NS.ServiceName
                        -> (Producer ByteString (SafeT n) ()
                            -> (SafeT n) (Producer ByteString (SafeT n) ()))
                        -> m ()
serveT = serveT_Timeout 600

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