diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -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 diff --git a/reserve.cabal b/reserve.cabal --- a/reserve.cabal +++ b/reserve.cabal @@ -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 maintainer: Simon Hengel 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 diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -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) = diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -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) diff --git a/src/Reserve.hs b/src/Reserve.hs --- a/src/Reserve.hs +++ b/src/Reserve.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -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 diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -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 diff --git a/test/OptionsSpec.hs b/test/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/OptionsSpec.hs @@ -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"]} diff --git a/test/ReserveSpec.hs b/test/ReserveSpec.hs new file mode 100644 --- /dev/null +++ b/test/ReserveSpec.hs @@ -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" diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilSpec.hs @@ -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)