reserve 0.1.1 → 0.1.2
raw patch · 11 files changed
+225/−71 lines, 11 filesdep +interpolatedep +mockerydep +streaming-commonsdep −base-compatdep ~http-kit
Dependencies added: interpolate, mockery, streaming-commons
Dependencies removed: base-compat
Dependency ranges changed: http-kit
Files
- driver/Main.hs +12/−0
- reserve.cabal +47/−33
- src/Interpreter.hs +3/−3
- src/Main.hs +0/−14
- src/Options.hs +6/−7
- src/Reserve.hs +9/−9
- src/Util.hs +9/−5
- test/Helper.hs +9/−0
- test/OptionsSpec.hs +20/−0
- test/ReserveSpec.hs +67/−0
- test/UtilSpec.hs +43/−0
+ driver/Main.hs view
@@ -0,0 +1,12 @@+module Main (main) where++import Network.Socket++import Options+import Reserve++main :: IO ()+main = withSocketsDo $ do+ withOptions $ \opts -> do+ putStrLn $ "http://localhost:" ++ show (optionsReservePort opts)+ run opts
reserve.cabal view
@@ -1,68 +1,82 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack+ name: reserve-version: 0.1.1+version: 0.1.2+bug-reports: https://github.com/sol/reserve/issues license: MIT license-file: LICENSE-copyright: (c) 2014 Simon Hengel+copyright: (c) 2014, 2015 Simon Hengel author: Simon Hengel <sol@typeful.net> maintainer: Simon Hengel <sol@typeful.net> synopsis: Reserve reloads web applications description: Universal and robust reloading for Haskell web applications category: Web+homepage: https://github.com/sol/reserve#readme build-type: Simple-cabal-version: >= 1.10 source-repository head type: git location: https://github.com/sol/reserve executable reserve- ghc-options:- -Wall hs-source-dirs:+ driver src- main-is:- Main.hs+ main-is: Main.hs other-modules: Interpreter Options Reserve Util+ Paths_reserve build-depends:- base == 4.*- , base-compat >= 0.6.0+ base ==4.*+ , bytestring , directory+ , http-kit >=0.5+ , http-types , network- , unix , process- , http-types- , http-kit >= 0.5- , bytestring- default-extensions: NoImplicitPrelude+ , streaming-commons+ , unix+ ghc-options: -Wall default-language: Haskell2010 test-suite spec- type:- exitcode-stdio-1.0- ghc-options:- -Wall -Werror+ type: exitcode-stdio-1.0 hs-source-dirs:- src, test- main-is:- Spec.hs+ test+ src+ main-is: Spec.hs+ other-modules:+ Helper+ OptionsSpec+ ReserveSpec+ UtilSpec+ Interpreter+ Options+ Reserve+ Util+ Paths_reserve build-depends:- base == 4.*- , base-compat+ QuickCheck+ , base ==4.*+ , bytestring , directory+ , hspec >=2+ , http-conduit+ , http-kit >=0.5+ , http-types+ , interpolate+ , mockery , network- , unix , process- , http-types- , http-kit- , bytestring-- , hspec >= 2- , QuickCheck- , http-conduit- , warp >= 3- default-extensions: NoImplicitPrelude+ , streaming-commons+ , unix+ , warp >=3+ ghc-options: -Wall default-language: Haskell2010
src/Interpreter.hs view
@@ -8,8 +8,6 @@ , reload ) where -import Prelude.Compat- import System.Process import System.Process.Internals import System.IO@@ -37,7 +35,9 @@ reload (Interpreter _ h) = hPutStrLn h ":reload" >> hFlush h signalProcess :: Signal -> ProcessHandle -> IO ()-#if MIN_VERSION_process(1,2,0)+#if MIN_VERSION_process(1,6,0)+signalProcess signal (ProcessHandle mvar _ _) =+#elif MIN_VERSION_process(1,2,0) signalProcess signal (ProcessHandle mvar _) = #else signalProcess signal (ProcessHandle mvar) =
− src/Main.hs
@@ -1,14 +0,0 @@-module Main (main) where--import Prelude.Compat--import Network--import Options-import Reserve--main :: IO ()-main = withSocketsDo $ do- withOptions $ \opts -> do- putStrLn $ "http://localhost:" ++ show (optionsReservePort opts)- run opts
src/Options.hs view
@@ -1,5 +1,6 @@ module Options ( Options (..)+, Port , withOptions , parseOptions , defaultOptions@@ -8,18 +9,14 @@ , Arg (..) ) where -import Prelude.Compat- import Data.Maybe import Data.List-import Text.Read.Compat+import Text.Read import System.Console.GetOpt import System.Environment import System.IO import System.Exit -import Network (PortNumber)- withOptions :: (Options -> IO ()) -> IO () withOptions action = do args <- getArgs@@ -32,9 +29,11 @@ ExitSuccess -> hPutStr stdout msg _ -> hPutStr stderr msg >> exitWith err +type Port = Int+ data Options = Options {- optionsPort :: PortNumber-, optionsReservePort :: PortNumber+ optionsPort :: Port+, optionsReservePort :: Port , optionsMainIs :: FilePath , optionsAppArgs :: [String] } deriving (Eq, Show)
src/Reserve.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-} module Reserve (run) where -import Prelude.Compat- import Control.Monad import Control.Exception import GHC.IO.Exception@@ -10,7 +9,8 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B-import Network+import Network.Socket+import Data.Streaming.Network (bindPortTCP) import Network.HTTP.Types import Network.HTTP.Toolkit@@ -23,20 +23,20 @@ data Session = Session Socket Interpreter openSession :: Options -> IO Session--- openSession opts = Session <$> listenOn (optionsReservePort opts) <*> Interpreter.new (optionsMainIs opts)-openSession opts = Session <$> listenOn (PortNumber $ optionsReservePort opts) <*> Interpreter.new (optionsMainIs opts)+openSession opts = Session <$> bindPortTCP (optionsReservePort opts) "*" <*> Interpreter.new (optionsMainIs opts) closeSession :: Session -> IO ()-closeSession (Session h i) = sClose h >> Interpreter.terminate i+closeSession (Session h i) = close h >> Interpreter.terminate i withSession :: Options -> (Session -> IO a) -> IO a withSession opts = bracket (openSession opts) closeSession run :: Options -> IO () run opts = withSession opts $ \(Session s interpreter) -> forever $ do- (h, _, _) <- accept s+ (sock, _) <- accept s Interpreter.reload interpreter Interpreter.start interpreter (optionsAppArgs opts)+ h <- socketToHandle sock ReadWriteMode c <- inputStreamFromHandle h let send :: ByteString -> IO () send = ignoreResourceVanished . B.hPutStr h@@ -52,8 +52,8 @@ where headers = [("Content-Type", "text/plain"), ("Connection", "close")] -httpRequest :: PortNumber -> (ByteString -> IO ()) -> Request BodyReader -> IO ()-httpRequest port send request@(Request method _ headers _) = connectRetry 200000 "localhost" port $ \mh -> case mh of+httpRequest :: Port -> (ByteString -> IO ()) -> Request BodyReader -> IO ()+httpRequest port send request@(Request method _ headers _) = connectRetry 200000 "localhost" port $ \ case Just h -> do sendRequest (B.hPutStr h) request{requestHeaders = setConnectionClose headers} inputStreamFromHandle h >>= readResponse True method >>= sendResponse send
src/Util.hs view
@@ -1,14 +1,16 @@ {-# LANGUAGE ScopedTypeVariables #-} module Util where -import Prelude.Compat- import Control.Concurrent import Control.Exception import System.IO-import Network+import Network.Socket (HostName, socketToHandle)+import qualified Data.ByteString.Char8 as B+import Data.Streaming.Network -connectRetry :: Int -> HostName -> PortNumber -> (Maybe Handle -> IO a) -> IO a+import Options (Port)++connectRetry :: Int -> HostName -> Port -> (Maybe Handle -> IO a) -> IO a connectRetry delay host port action = go 0 where go n@@ -18,4 +20,6 @@ tryConnect = try $ bracket connect hClose (action . Just) retry n = threadDelay delay >> go (succ n)- connect = connectTo host $ PortNumber port+ connect = do+ (sock, _) <- getSocketTCP (B.pack host) port+ socketToHandle sock ReadWriteMode
+ test/Helper.hs view
@@ -0,0 +1,9 @@+module Helper (+ module Test.Hspec+, module Control.Applicative+, module Test.Mockery.Directory+) where++import Test.Hspec+import Test.Mockery.Directory+import Control.Applicative
+ test/OptionsSpec.hs view
@@ -0,0 +1,20 @@+module OptionsSpec (main, spec) where++import Test.Hspec++import Options++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "parseOptions" $ do+ it "parses port" $ do+ parseOptions ["--port", "8000"] `shouldBe` Right defaultOptions {optionsPort = 8000}++ it "allows to specify path to Main module" $ do+ parseOptions ["Foo.hs"] `shouldBe` Right defaultOptions {optionsMainIs = "Foo.hs"}++ it "allows to specify addition arguments for app" $ do+ parseOptions ["--port", "8000", "--", "production", "--port", "3000"] `shouldBe` Right defaultOptions {optionsPort = 8000, optionsAppArgs = ["production", "--port", "3000"]}
+ test/ReserveSpec.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+module ReserveSpec (spec) where++import Helper++import qualified Data.ByteString.Lazy.Char8 as L+import Control.Exception+import Control.Concurrent+import Network.Socket+import Network.Socket.ByteString (sendAll)+import Data.Streaming.Network (getSocketTCP)+import Network.HTTP.Conduit+import Data.String.Interpolate++import Options+import Reserve++appWithResponse :: String -> IO ()+appWithResponse response = writeFile "app.hs" [i|+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Network.Wai+import Network.HTTP.Types+import Network.Wai.Handler.Warp (run)+import qualified Data.ByteString.Lazy.Char8 as B++app :: Application+app _ = ($ responseLBS status200 [("Content-Type", "text/plain")] #{response})++main :: IO ()+main = run 3000 app+|]++literal :: String -> String+literal = show++withServer :: IO () -> IO ()+withServer action = inTempDirectory $ do+ appWithResponse (literal "hello")+ mvar <- newEmptyMVar+ bracket (runReserve mvar) killThread (const $ yield >> action)+ takeMVar mvar+ where+ runReserve mvar = forkIO $ run defaultOptions {optionsMainIs = "app.hs"} `finally` putMVar mvar ()++spec :: Spec+spec = around_ withServer $ do+ describe "run" $ do+ it "runs app" $ do+ simpleHttp "http://localhost:12000/" `shouldReturn` "hello"++ it "reloads app" $ do+ simpleHttp "http://localhost:12000/" `shouldReturn` "hello"+ appWithResponse (literal "foo")+ simpleHttp "http://localhost:12000/" `shouldReturn` "foo"++ it "can deal with large response bodies" $ do+ appWithResponse [i|(B.take 100000 $ B.cycle #{literal "foo bar baz\n"})|]+ simpleHttp "http://localhost:12000/large-response" `shouldReturn` (L.take 100000 $ L.cycle "foo bar baz\n")++ context "when client closes connection early" $ do+ it "ignores that client" $ do+ (sock, _) <- getSocketTCP "localhost" 12000+ sendAll sock "GET / HTTP/1.1\r\n\r\n"+ close sock+ simpleHttp "http://localhost:12000/" `shouldReturn` "hello"
+ test/UtilSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+module UtilSpec (main, spec) where++import Test.Hspec+import System.IO+import Control.Exception+import Control.Concurrent+import Network.Socket+import Network.Socket.ByteString (sendAll)+import Data.Streaming.Network (bindPortTCP)++import Util++main :: IO ()+main = hspec spec++startTestServer :: IO ()+startTestServer = bracket (bindPortTCP 6060 "*") close $ \s -> do+ (sock, _) <- accept s+ sendAll sock "foo"+ close sock++withTestServer :: Int -> IO a -> IO a+withTestServer delay = bracket (forkIO $ threadDelay delay >> startTestServer) killThread . const++spec :: Spec+spec = do+ describe "connectRetry" $ do+ it "connects to a TCP port" $ do+ withTestServer 0 $ do+ connectRetry 5000 "localhost" 6060 $ \(Just h) -> do+ hGetContents h `shouldReturn` "foo"++ context "when server socket is not yet open" $ do+ it "retries" $ do+ withTestServer 20000 $ do+ connectRetry 5000 "localhost" 6060 $ \(Just h) -> do+ hGetContents h `shouldReturn` "foo"++ context "after 10 retries" $ do+ it "gives up" $ do+ withTestServer 20000 $ do+ connectRetry 500 "localhost" 6060 (`shouldBe` Nothing)