houseman (empty) → 0.1.0
raw patch · 13 files changed
+602/−0 lines, 13 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, directory, dotenv, houseman, hspec, interpolate, io-streams, mockery, mtl, optparse-generic, parsers, process, silently, streaming-commons, temporary, text, time, trifecta, unix
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Main.hs +45/−0
- houseman.cabal +109/−0
- src/Houseman.hs +84/−0
- src/Houseman/Internal.hs +92/−0
- src/Houseman/Logger.hs +90/−0
- src/Houseman/Types.hs +16/−0
- src/Procfile/Parse.hs +29/−0
- src/Procfile/Types.hs +12/−0
- test/HousemanSpec.hs +61/−0
- test/Procfile/ParseSpec.hs +31/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Daisuke Fujimura (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Daisuke Fujimura nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Data.Maybe+import Data.Version (showVersion)+import Options.Generic+import System.Exit+import Text.Trifecta (parseFromFile)++import qualified Houseman+import qualified Paths_houseman+import qualified Procfile.Parse+import Procfile.Types++data Option = Start { filename :: Maybe FilePath <?> "Path of Procfile" } |+ Run { command :: String <?> "Command to run"+ , filename :: Maybe FilePath <?> "Path of Procfile"+ } |+ Version+ deriving (Generic, Show)++instance ParseRecord Option++main :: IO ()+main = do+ (opts :: Option) <- getRecord "Manage Procfile-based application"+ case opts of+ Start {filename} -> parseProcFile (fromMaybe "Procfile" (unHelpful filename))+ >>= Houseman.start >>= exitWith+ Run {filename,command} -> parseProcFile (fromMaybe "Procfile" (unHelpful filename))+ >>= Houseman.run (unHelpful command) >>= exitWith+ Version -> putStrLn (showVersion Paths_houseman.version)++parseProcFile :: FilePath -> IO Procfile+parseProcFile path = do+ mProcfile <- parseFromFile Procfile.Parse.procfile path+ case mProcfile of+ Nothing -> exitWith (ExitFailure 1)+ Just p -> return p
+ houseman.cabal view
@@ -0,0 +1,109 @@+-- This file has been generated from package.yaml by hpack version 0.13.0.+--+-- see: https://github.com/sol/hpack++name: houseman+version: 0.1.0+synopsis: A Haskell implementation of Foreman+homepage: https://github.com/fujimura/houseman#readme+bug-reports: https://github.com/fujimura/houseman/issues+license: MIT+license-file: LICENSE+maintainer: Daisuke Fujimura <me@fujmuradaisuke.com>+category: Development+build-type: Simple+cabal-version: >= 1.10++source-repository head+ type: git+ location: https://github.com/fujimura/houseman++library+ hs-source-dirs:+ src+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >= 4.7 && < 5+ , bytestring+ , text+ , unix+ , process+ , trifecta+ , parsers+ , time+ , optparse-generic >= 1.1.0+ , dotenv+ , directory+ , streaming-commons+ , mtl+ , io-streams+ exposed-modules:+ Houseman+ Houseman.Internal+ Houseman.Logger+ Houseman.Types+ Procfile.Parse+ Procfile.Types+ default-language: Haskell2010++executable houseman+ main-is: Main.hs+ hs-source-dirs:+ app+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >= 4.7 && < 5+ , bytestring+ , text+ , unix+ , process+ , trifecta+ , parsers+ , time+ , optparse-generic >= 1.1.0+ , dotenv+ , directory+ , streaming-commons+ , mtl+ , io-streams+ , houseman+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ , src+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >= 4.7 && < 5+ , bytestring+ , text+ , unix+ , process+ , trifecta+ , parsers+ , time+ , optparse-generic >= 1.1.0+ , dotenv+ , directory+ , streaming-commons+ , mtl+ , io-streams+ , hspec == 2.*+ , temporary+ , silently+ , mockery >= 0.3+ , interpolate+ , QuickCheck+ other-modules:+ HousemanSpec+ Procfile.ParseSpec+ Houseman+ Houseman.Internal+ Houseman.Logger+ Houseman.Types+ Procfile.Parse+ Procfile.Types+ default-language: Haskell2010
+ src/Houseman.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Houseman where++import Control.Concurrent+import Control.Monad+import Control.Monad.Cont+import Data.Function+import Data.List+import System.Directory+import System.Environment+import System.Exit+import System.Posix.Signals+import System.Process++import qualified Configuration.Dotenv as Dotenv+import Data.Streaming.Process (StreamingProcessHandle)++import Houseman.Internal (terminateAndWaitForProcess,+ withAllExit, withAnyExit, withProcess)+import Houseman.Logger (installLogger, newLogger, runLogger,+ stopLogger)+import Houseman.Types+import Procfile.Types++-- | Runs `App` in `Procfile` with given name.+run :: String -> Procfile -> IO ExitCode+run cmd' apps = case find (\App{cmd} -> cmd == cmd') apps of+ Just app -> Houseman.start [app] -- TODO Remove color in run command+ Nothing -> die ("Command '" ++ cmd' ++ "' not found in Procfile")++-- | Starts all `App`s in given `Procfile`.+start :: Procfile -> IO ExitCode+start apps = do+ print apps++ -- Allocate logger+ logger <- newLogger++ -- Run apps+ (`runContT` return) $ do+ phs <- mapM (ContT . withApp logger) apps+ liftIO $ do+ -- Get a MVar to detect termination of a process+ readyToTerminate <- newEmptyMVar++ -- Output logs to stdout+ runLogger logger++ -- Fill MVar with signal+ [sigINT, sigTERM, keyboardSignal] `forM_` \signal ->+ installHandler signal (Catch (putMVar readyToTerminate ())) Nothing++ -- Fill MVar with any failure+ _ <- forkIO $ withAnyExit (/= ExitSuccess) phs (putMVar readyToTerminate ())+ -- Fill MVar with all success+ _ <- forkIO $ withAllExit (== ExitSuccess) phs (putMVar readyToTerminate ())++ -- Wait for the termination+ takeMVar readyToTerminate++ -- Terminate all and exit+ mapM_ terminateAndWaitForProcess phs+ stopLogger logger+ putStrLn "bye"+ return ExitSuccess++-- | Runs given `App` with given `Logger`, invokes action with the process+-- handle of the `App`, and returns result of the action.+withApp :: Logger -> App -> (StreamingProcessHandle -> IO a) -> IO a+withApp logger App {name,cmd} action = do+ -- Build environment variables to run app.+ -- .env supersedes environment from current process.+ envs <- nubBy ((==) `on` fst) . mconcat <$> sequence [getEnvsInDotEnvFile, getEnvironment]+ withProcess (shell cmd) { env = Just envs } $ \(out,err,ph) -> do+ _ <- forkIO $ forM_ [out,err] (installLogger name logger)+ action ph+ where+ getEnvsInDotEnvFile :: IO [Env]+ getEnvsInDotEnvFile = do+ d <- doesFileExist ".env"+ if d then Dotenv.parseFile ".env" else return []
+ src/Houseman/Internal.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Houseman.Internal+ ( terminateAndWaitForProcess+ , withAllExit+ , withAnyExit+ , withProcess+ ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Maybe+import GHC.IO.Exception+import GHC.IO.Handle+import System.IO+import System.Process++import Data.Streaming.Process (Inherited (..), StreamingProcessHandle,+ getStreamingProcessExitCode,+ streamingProcess,+ streamingProcessHandleRaw,+ waitForStreamingProcess)++-- | Watch exit of given process handles, and if any of them exited and+-- passed given predicate, runs action.+withAnyExit+ :: (ExitCode -> Bool) -- ^ Predicate+ -> [StreamingProcessHandle] -- ^ Process handles to watch+ -> IO a -- ^ Action to run+ -> IO a+withAnyExit predicate phs action = go+ where+ go = do+ exits <- catMaybes <$> mapM getStreamingProcessExitCode phs+ if any predicate exits+ then action+ else threadDelay 1000 >> go++-- | Watch exit of given process handles, and if all of them exited and+-- passed given predicate, runs action.+withAllExit+ :: (ExitCode -> Bool) -- ^ Predicate+ -> [StreamingProcessHandle] -- ^ Process handles to watch+ -> IO a -- ^ Action to run+ -> IO a+withAllExit predicate phs action = go+ where+ go = do+ exits <- mapM getStreamingProcessExitCode phs+ if all isJust exits && all predicate (catMaybes exits)+ then action+ else threadDelay 1000 >> go++-- | Terminates and waits for given process.+terminateAndWaitForProcess :: StreamingProcessHandle -> IO ExitCode+terminateAndWaitForProcess ph = do+ let ph' = streamingProcessHandleRaw ph+ b <- getStreamingProcessExitCode ph+ case b of+ Just exitcode -> return exitcode+ Nothing -> do+ terminateProcess ph'+ waitForStreamingProcess ph++-- | Runs given process and invoke action with stdout, stderr, process handle from it.+-- stdout and stderr will be closed after action.+withProcess+ :: CreateProcess -- ^ The process+ -> ((Handle, Handle, StreamingProcessHandle) -> IO a) -- ^ Action takes stdout, stderr and process handle+ -> IO a+withProcess p action = bracket before restore action+ where+ before = do+ (Inherited, out :: Handle, err :: Handle, ph) <-+ streamingProcess p { std_out = CreatePipe+ , std_err = CreatePipe+ }+ encoding <- mkTextEncoding "utf8"+ forM_ [out,err] $ \h -> do+ hSetBuffering h NoBuffering+ hSetEncoding h encoding+ hSetNewlineMode h universalNewlineMode+ return (out,err,ph)+ restore (out,err,_) = do+ close out+ close err+ close x = do+ c <- hIsClosed x+ unless c $ hClose x
+ src/Houseman/Logger.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Houseman.Logger+ ( newLogger+ , installLogger+ , runLogger+ , readLogger+ , stopLogger+ ) where++import Control.Concurrent+import Data.Char+import Data.Monoid+import Data.Text (Text)+import Data.Time+import GHC.IO.Handle++import qualified Data.ByteString as ByteString+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text+import qualified Data.Text.IO as Text+import qualified System.IO.Streams as Streams++import Houseman.Types++-- | Instantiates new 'Logger'.+newLogger :: IO Logger+newLogger = do+ c <- newChan+ m <- newEmptyMVar+ return $ Logger c m++-- | Reads one `Log` from given `Logger`.+readLogger :: Logger -> IO Log+readLogger (Logger logger _) = readChan logger++-- | Runs given `Logger`. Logs will be output to `System.IO.stdout`. When `Logger` gets+-- `LogStop`, logging will be stopped.+runLogger :: Logger -> IO ()+runLogger (Logger logger done) = do+ _ <- forkIO $ go []+ return ()+ where+ go cs = do+ log' <- readChan logger+ case log' of+ Log (name,l) -> do+ let (color, cs') = name `lookupOrInsertNewColor` cs+ t <- Text.pack <$> formatTime defaultTimeLocale "%H:%M:%S" <$> getZonedTime+ Text.putStrLn (colorString color (t <> " " <> Text.pack name <> ": ") <> l )+ go cs'+ LogStop -> putMVar done ()+ lookupOrInsertNewColor :: String -> [(String, Color)] -> (Color, [(String, Color)])+ lookupOrInsertNewColor x xs = case x `lookup` xs of+ Just color -> (color,xs)+ Nothing -> let color = colors !! length xs+ in (color,(x,color):xs)+ colors :: [Color]+ colors = cycle [32..36]++ colorString :: Color -> Text -> Text+ colorString c x = "\x1b[" <> Text.pack (show c) <> "m" <> x <> "\x1b[0m"++-- | Installs new `Handle` as a source of given `Logger`.+installLogger+ :: String -- ^ Name of source+ -> Logger -- ^ `Logger` instance+ -> Handle -- ^ The source+ -> IO ()+installLogger name (Logger logger _) handle = do+ is <- Streams.handleToInputStream handle >>=+ Streams.lines >>=+ Streams.map (Text.decodeUtf8With Text.lenientDecode . ByteString.filter (/= fromIntegral (ord '\r')))+ os <- Streams.makeOutputStream out+ Streams.connect is os+ where+ out (Just l) = writeChan logger (Log (name,l))+ out Nothing = return ()++-- | Stops `Logger`.+stopLogger :: Logger -> IO ()+stopLogger (Logger logger stop) = do+ -- Wait a while to flush logs+ -- FIXME This won't guarantee all logs will be flushed out.+ threadDelay 1000+ writeChan logger LogStop+ takeMVar stop
+ src/Houseman/Types.hs view
@@ -0,0 +1,16 @@+module Houseman.Types where++import Control.Concurrent (Chan, MVar)+import Data.Text (Text)++data Log =+ Log (String, Text) -- ^ Name and log itself+ | LogStop -- ^ To stop log+ deriving (Eq,Ord,Show)++data Logger =+ Logger { logs :: Chan Log -- ^ A channel to store logs+ , done :: MVar () -- ^ Filled when logging is finished+ }++type Color = Int -- Color of log
+ src/Procfile/Parse.hs view
@@ -0,0 +1,29 @@+module Procfile.Parse where++import Control.Applicative+import Control.Monad+import Text.Parser.LookAhead+import Text.Trifecta hiding (spaces)++import Procfile.Types (App (App), Procfile)++procfile :: Parser Procfile+procfile = proc `sepEndBy` (void newline <|> eof)++proc :: Parser App+proc = do+ n <- name+ _ <- spaces+ c <- cmd+ return $ App n c++name :: Parser String+name = some (alphaNum <|> char '_') <* char ':'+ <?> "name"++cmd :: Parser String+cmd = manyTill anyChar (eof <|> lookAhead (void newline))+ <?> "cmd"++spaces :: CharParsing m => m ()+spaces = skipMany (char ' ') <?> "white space excluding newline"
+ src/Procfile/Types.hs view
@@ -0,0 +1,12 @@+module Procfile.Types where++-- | Procfile, that consists of a list of `App`s.+type Procfile = [App]++-- | An environmental variable.+type Env = (String, String)++-- | An app in `Procfile`.+data App = App { name :: String+ , cmd :: String+ } deriving (Eq,Ord,Show)
+ test/HousemanSpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HousemanSpec ( main, spec ) where++import System.Environment++import Data.Streaming.Process (StreamingProcessHandle,+ waitForStreamingProcess)++import qualified Houseman+import Houseman.Logger (newLogger, readLogger)+import Houseman.Types+import Procfile.Types++import System.IO.Silently (capture)+import Test.Hspec+import Test.Mockery.Directory (inTempDirectory)+++main :: IO ()+main = hspec spec++runApp :: Logger -> App -> IO StreamingProcessHandle+runApp l a = Houseman.withApp l a return++spec :: Spec+spec = describe "Houseman" $ do+ describe "start" $ do+ it "should run given apps" $ do+ let apps = [ App "echo1" "./test/fixtures/echo.sh foo bar"+ , App "echo2" "./test/fixtures/echo.sh baz 🙈"+ ]+ (result,_) <- capture $ Houseman.start apps+ result `shouldContain` "echo1: \ESC[0mfoo"+ result `shouldContain` "echo1: \ESC[0mbar"+ result `shouldContain` "echo2: \ESC[0mbaz"+ result `shouldContain` "echo2: \ESC[0m🙈"++ describe "runApp" $ do+ it "should run given process" $ do+ log' <- newLogger+ Houseman.withApp log' (App "echo" "ECHO=1 ./test/fixtures/echo.sh foo 🙈") $ \ph -> do+ _ <- waitForStreamingProcess ph+ readLogger log' `shouldReturn` Log ("echo", "ECHO=1")+ readLogger log' `shouldReturn` Log ("echo", "foo")+ readLogger log' `shouldReturn` Log ("echo", "🙈")++ it "should use .env as dotenv file, which supersedes original environment" $ inTempDirectory $ do+ setEnv "BAZ" "3"+ writeFile ".env" "BAZ=2"+ log' <- newLogger+ Houseman.withApp log' (App "echo" "printenv BAZ") $ \ph -> do+ _ <- waitForStreamingProcess ph+ readLogger log' `shouldReturn` Log ("echo", "2")++ it "should log stderr" $ do+ log' <- newLogger+ Houseman.withApp log' (App "echo" "echo ERROR 1>&2") $ \ph -> do+ _ <- waitForStreamingProcess ph+ readLogger log' `shouldReturn` Log ("echo", "ERROR")
+ test/Procfile/ParseSpec.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Procfile.ParseSpec ( main, spec ) where++import Data.ByteString (ByteString)+import Text.Trifecta.Parser+import Text.Trifecta.Result++import Data.List+import qualified Procfile.Parse as Parse+import Procfile.Types++import Test.Hspec++parse :: Parser a -> ByteString -> a+parse p bs = case parseByteString p mempty bs of+ Success x -> x+ Failure doc -> error (show doc)++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "Procfile.Parse" $ do+ describe "procfile" $ do+ it "should parse web: foo\nworker: bar" $+ parse Parse.procfile "web: foo -a 1\nworker: bar --b=c baz" `shouldBe`+ [ App "web" "foo -a 1", App "worker" "bar --b=c baz"]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}