Serve.hs

-- | Serve

{-# LANGUAGE OverloadedStrings #-}

module Network.HTTP.Pony.Serve where

import           Control.Monad.IO.Class (MonadIO(..))
import           Data.ByteString.Char8 (ByteString)
import qualified Network.Socket as NS
import           Pipes (Producer, Consumer, runEffect, (>->))
import           Pipes.Network.TCP.Safe (HostPreference())
import           Pipes.Network.TCP.Safe (fromSocket, toSocket)
import qualified Pipes.Network.TCP.Safe as PipesNetwork
import           Pipes.Safe (MonadSafe(), runSafeT)

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

serveWithPipe :: (Monad m)  => Producer ByteString m a
                            -> Consumer ByteString m b
                            -> (Producer ByteString m a -> m (Producer ByteString m b))
                            -> m ()
serveWithPipe pull push pipe = do
  r <- pipe pull
  runEffect - r >-> push

  pure ()

serveWithSocket :: (MonadIO m)  => (NS.Socket, NS.SockAddr)
                              -> (Producer ByteString m () -> m (Producer ByteString m ()))
                              -> m ()
serveWithSocket (s,_) =
  let
    pull = fromSocket s 4096 >> shutdownReceive s
    push = toSocket s >> shutdownSend s
  in

  serveWithPipe pull push


run :: (MonadSafe m) => HostPreference
                     -> NS.ServiceName
                     -> (Producer ByteString IO () -> IO (Producer ByteString IO ()))
                     -> m ()
run host service app =
  PipesNetwork.serve host service - \socket -> do
    serveWithSocket socket app

    -- pure ()

    -- r <- serveWithSocket socket app
    -- case r of
    --   Nothing -> pure ()
    --   Just err -> pure () -- log - view packed - show err