reserve 0.0.0 → 0.1.0
raw patch · 5 files changed
+220/−1 lines, 5 files
Files
- reserve.cabal +6/−1
- src/Interpreter.hs +45/−0
- src/Options.hs +89/−0
- src/Reserve.hs +61/−0
- src/Util.hs +19/−0
reserve.cabal view
@@ -1,5 +1,5 @@ name: reserve-version: 0.0.0+version: 0.1.0 license: MIT license-file: LICENSE copyright: (c) 2014 Simon Hengel@@ -22,6 +22,11 @@ src main-is: Main.hs+ other-modules:+ Interpreter+ Options+ Reserve+ Util build-depends: base == 4.* , base-compat >= 0.5.0
+ src/Interpreter.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP #-}+module Interpreter (+ Interpreter+, new+, terminate+, start+, stop+, reload+) where++import System.Process+import System.Process.Internals+import System.IO+import System.Posix.Signals hiding (signalProcess)+import qualified System.Posix.Signals as Posix+import Control.Concurrent++data Interpreter = Interpreter ProcessHandle Handle++new :: FilePath -> IO Interpreter+new src = do+ (Just hIn, Nothing, Nothing, processHandle) <- createProcess $ (proc "ghci" ["-v0", src]) {std_in = CreatePipe}+ return (Interpreter processHandle hIn)++terminate :: Interpreter -> IO ()+terminate i@(Interpreter p h) = stop i >> hClose h >> waitForProcess p >> return ()++start :: Interpreter -> [String] -> IO ()+start (Interpreter _ h) args = hPutStrLn h (unwords $ ":main" : args) >> hFlush h++stop :: Interpreter -> IO ()+stop (Interpreter p _) = signalProcess sigINT p++reload :: Interpreter -> IO ()+reload (Interpreter _ h) = hPutStrLn h ":reload" >> hFlush h++signalProcess :: Signal -> ProcessHandle -> IO ()+#if MIN_VERSION_process(1,2,0)+signalProcess signal (ProcessHandle mvar _) =+#else+signalProcess signal (ProcessHandle mvar) =+#endif+ withMVar mvar $ \p -> case p of+ OpenHandle pid -> Posix.signalProcess signal pid+ _ -> return ()
+ src/Options.hs view
@@ -0,0 +1,89 @@+module Options (+ Options (..)+, withOptions+, parseOptions+, defaultOptions++-- exported to silence warnings+, Arg (..)+) where++import Control.Applicative+import Data.Maybe+import Data.List+import Text.Read.Compat+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+ case parseOptions args of+ Left err -> uncurry exitWithMessage err+ Right opts -> action opts++exitWithMessage :: ExitCode -> String -> IO ()+exitWithMessage err msg = case err of+ ExitSuccess -> hPutStr stdout msg+ _ -> hPutStr stderr msg >> exitWith err++data Options = Options {+ optionsPort :: PortNumber+, optionsReservePort :: PortNumber+, optionsMainIs :: FilePath+, optionsAppArgs :: [String]+} deriving (Eq, Show)++setPort :: Integer -> Options -> Options+setPort p c = c {optionsPort = fromInteger p}++setReservePort :: Integer -> Options -> Options+setReservePort p c = c {optionsReservePort = fromInteger p}++defaultOptions :: Options+defaultOptions = Options 3000 12000 "src/Main.hs" []++type Result = Either NoOptions Options++data NoOptions = Help | InvalidArgument String String++data Arg a = Arg {+ argumentName :: String+, argumentParser :: String -> Maybe a+, argumentSetter :: a -> Options -> Options+}++mkOption :: [Char] -> String -> Arg a -> String -> OptDescr (Result -> Result)+mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help+ where+ arg :: String -> Result -> Result+ arg input x = x >>= \c -> case parser input of+ Just n -> Right (setter n c)+ Nothing -> Left (InvalidArgument name input)++options :: [OptDescr (Result -> Result)]+options = [+ Option [] ["help"] (NoArg (const $ Left Help)) "display this help and exit"+ , mkOption "p" "port" (Arg "PORT" readMaybe setPort) ("port of the web application (default: " ++ show (optionsPort defaultOptions) ++ ")")+ , mkOption "" "reserve-port" (Arg "PORT" readMaybe setReservePort) ("port reserve listens on (default: " ++ show (optionsReservePort defaultOptions) ++ ")")+ ]++parseOptions :: [String] -> Either (ExitCode, String) Options+parseOptions allArgs = case getOpt Permute options args of+ (_, _, err:_) -> tryHelp err+ (_, _:arg:_, _) -> tryHelp ("unexpected argument `" ++ arg ++ "'\n")+ (opts, mainIs, []) -> case foldl' (flip id) (Right defaultOptions) opts of+ Left Help -> Left (ExitSuccess, usage)+ Left (InvalidArgument flag value) -> tryHelp ("invalid argument `" ++ value ++ "' for `--" ++ flag ++ "'\n")+ Right x -> Right x {optionsMainIs = fromMaybe (optionsMainIs defaultOptions) $ listToMaybe mainIs, optionsAppArgs = appArgs}+ where+ tryHelp msg = Left (ExitFailure 1, "reserve: " ++ msg ++ "Try `reserve --help' for more information.\n")+ usage = usageInfo ("Usage: reserve [OPTION]... [MAIN] [-- ARG...]\n\nOPTIONS") options ++ helpForMain ++ helpForAppArgs+ helpForMain = "\nThe optional MAIN argument is a path to a module that exports a `main' function. (default: " ++ optionsMainIs defaultOptions ++ ")\n"+ helpForAppArgs = "\nAll arguments following the optional `--' are passed to the web application.\n"++ (args, appArgs) = drop 1 <$> span (/= "--") allArgs
+ src/Reserve.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+module Reserve (run) where++import Control.Applicative+import Control.Monad+import Control.Exception+import GHC.IO.Exception+import System.IO++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Network++import Network.HTTP.Types+import Network.HTTP.Toolkit++import Util+import Options+import Interpreter (Interpreter)+import qualified Interpreter++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)++closeSession :: Session -> IO ()+closeSession (Session h i) = sClose 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 int) -> forever $ do+ (h, _, _) <- accept s+ Interpreter.reload int+ Interpreter.start int (optionsAppArgs opts)+ c <- inputStreamFromHandle h+ let send :: ByteString -> IO ()+ send = ignoreResourceVanished . B.hPutStr h+ readRequest True c >>= httpRequest (optionsPort opts) send+ Interpreter.stop int+ ignoreResourceVanished $ hClose h++ignoreResourceVanished :: IO () -> IO ()+ignoreResourceVanished action = catchJust (guard . (== ResourceVanished) . ioe_type) action return++gatewayTimeout :: (ByteString -> IO ()) -> IO ()+gatewayTimeout send = simpleResponse send gatewayTimeout504 headers "timeout"+ 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+ Just h -> do+ sendRequest (B.hPutStr h) request{requestHeaders = setConnectionClose headers}+ inputStreamFromHandle h >>= readResponse True method >>= sendResponse send+ Nothing -> gatewayTimeout send+ where+ setConnectionClose = (("Connection", "close") :) . filter ((/= "Connection") . fst)
+ src/Util.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Util where++import Control.Concurrent+import Control.Exception+import System.IO+import Network++connectRetry :: Int -> HostName -> PortNumber -> (Maybe Handle -> IO a) -> IO a+connectRetry delay host port action = go 0+ where+ go n+ | n < (10 :: Int) = do+ tryConnect >>= either (\(_ :: IOException) -> retry n) return+ | otherwise = action Nothing++ tryConnect = try $ bracket connect hClose (action . Just)+ retry n = threadDelay delay >> go (succ n)+ connect = connectTo host $ PortNumber port