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.Attoparsec (ParsingError(..))
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 qualified Network.HTTP.Pony.Builder as Builder
import           Network.HTTP.Pony.Helper ((-), shutdownSend, shutdownReceive)
import qualified Network.HTTP.Pony.Parser as Parser
import           Network.HTTP.Pony.Type (Application, App, Middleware, Request, Response)
import           Prelude hiding ((-), log)

-- http :: (Monad m) => Application m ByteString ByteString a b
--                   -> (Producer ByteString m a -> m (Producer ByteString m ()))
http :: (Monad m) => Middleware m
                                (Producer ByteString m a)
                                (Producer ByteString m ())
                                (Request ByteString m a)
                                (Response ByteString m b)
http app pull = do
  maybeRequest <- Parser.parseMessage pull (pure ())

  case maybeRequest of
    Just (Right request) -> do
      response <- app request

      pure - Builder.message response >> pure ()

    _ -> pure - pure ()

    -- Just (Left err) -> pure - pure - err
    -- _ -> pure Nothing


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