http-pony 0.1.0.6 → 0.1.0.7

raw patch · 3 files changed

+73/−33 lines, 3 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• http-pony.cabal +1/−2
• src/Network/HTTP/Pony/Helper.hs +11/−3
• src/Network/HTTP/Pony/Serve.hs +61/−28

@@ -1,5 +1,5 @@ name:                http-pony-version:             0.1.0.6+version:             0.1.0.7 synopsis:            A type unsafe http library license:             BSD3 license-file:        LICENSE@@ -27,7 +27,6 @@                        , pipes-safe >=2.2                        , transformers >=0.4                        , exceptions >= 0.8.3-                         -- , case-insensitive >= 1.2.0.7                        -- , foreign-store >= 0.2

@@ -3,13 +3,21 @@ module Network.HTTP.Pony.Helper where  import Control.Monad.IO.Class (MonadIO(..))-import Network.Socket (Socket, ShutdownCmd(..), shutdown)+import Network.Socket (Socket, ShutdownCmd(..), shutdown, isConnected)+import Control.Monad (when)+import Prelude hiding ((-))  infixr 0 - f - x = f x  shutdownSend :: (MonadIO m) => Socket -> m ()-shutdownSend = liftIO . flip shutdown ShutdownSend+shutdownSend s = liftIO - do+  connected <- isConnected s+  when connected - do+    shutdown s ShutdownSend  shutdownReceive :: (MonadIO m) => Socket -> m ()-shutdownReceive = liftIO . flip shutdown ShutdownReceive+shutdownReceive s = liftIO - do+  connected <- isConnected s+  when connected - do+    shutdown s ShutdownReceive

@@ -2,81 +2,114 @@  module Network.HTTP.Pony.Serve where +import           Prelude hiding ((-), log)+ import           Control.Exception (IOException)-import           Control.Monad.Catch (MonadCatch)-import           Control.Monad.Catch (MonadMask)+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)+import           Pipes (Effect, Producer, Consumer, runEffect, (>->), await, yield) import           Pipes.Network.TCP.Safe (HostPreference())-import           Pipes.Network.TCP.Safe (fromSocket, toSocket, connect, connectSock-                                        , closeSock)+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)-import           Prelude hiding ((-), log)  -serveWithSocket :: (MonadSafe m, MonadCatch m)  => (NS.Socket, NS.SockAddr)+defaultTimeout :: Int+defaultTimeout = 600++serveWithSocket :: (MonadSafe m, MonadCatch m)  =>+                                   (NS.Socket, NS.SockAddr)                                 -> (Producer ByteString m () -> m (Producer ByteString m ()))                                 -> m ()-serveWithSocket (s,_) =+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 = fromSocket s 4096-    push = do+    pull = do+      fromSocketTimeout (timeout * 1000000) s 4096++    push = toSocketTimeout (timeout * 1000000) s++    pushWithCallbackOnEmptyToShutdownSend = 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+          yield x+          pushWithCallbackOnEmptyToShutdownSend   in -  serveWithPipe pull push+  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. -serveT :: (MonadSafe m, MonadMask n, MonadIO n)-               => (n () -> IO ())+              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 exit host service app =+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 - NS.setSocketOption (fst socket) NS.NoDelay 1+    liftIO - do+      NS.setSocketOption (fst socket) NS.NoDelay 1 -    exit - runSafeT (serveWithSocket socket app)+    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