Serve.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP.Pony.Serve where

import           Control.Exception (IOException)
import           Control.Monad.Catch (MonadCatch)
import           Control.Monad.Catch (MonadMask)
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)
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, tryP, throwM)

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


serveWithSocket :: (MonadSafe m, MonadCatch 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 - do
          --   connected <- NS.isConnected s
          --   putStrLn - "socket connected? " <> show connected
          --   if connected
          --      then do
          --       shutdownSend s
          --      else
          --       pure ()

          let cont = () <$ await
          r <- tryP (shutdownSend s)
          case r of
            Right _ -> cont
            Left e -> do
              -- liftIO - putStrLn - "Caught: " <> show e

              cont

              throwM (e :: IOException)

        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