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)
import           Prelude hiding ((-), log)

serve :: (MonadIO m)  => Producer ByteString m a
                      -> Consumer ByteString m b
                      -> Application m ByteString ByteString a b
                      -> m (Maybe ParsingError)
serve pull push app = do
  maybeRequest <- Parser.parseMessage pull (pure ())

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

      runEffect -
        Builder.message response >-> push

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



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

  serve pull push


run :: (MonadSafe m) => HostPreference
                     -> NS.ServiceName
                     -> App
                     -> m ()
run host service app =
  PipesNetwork.serve host service - \socket -> do
    r <- serveWithSocket socket app
    case r of
      Nothing -> pure ()
      Just err -> pure () -- log - view packed - show err