diff --git a/Data/Conduit/LogFile.hs b/Data/Conduit/LogFile.hs --- a/Data/Conduit/LogFile.hs +++ b/Data/Conduit/LogFile.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Data.Conduit.LogFile ( RotatingLog , openRotatingLog diff --git a/Data/Conduit/Process/Unix.hs b/Data/Conduit/Process/Unix.hs --- a/Data/Conduit/Process/Unix.hs +++ b/Data/Conduit/Process/Unix.hs @@ -54,7 +54,9 @@ fdToHandle) import System.Posix.Signals (sigKILL, signalProcess) import System.Posix.Types (CPid (..)) -import System.Process +import System.Process (CmdSpec (..), CreateProcess (..), + StdStream (..), createProcess, + terminateProcess, waitForProcess) import System.Process.Internals (ProcessHandle (..), ProcessHandle__ (..)) diff --git a/Keter/App.hs b/Keter/App.hs --- a/Keter/App.hs +++ b/Keter/App.hs @@ -16,12 +16,12 @@ import Control.Arrow ((***)) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM -import Control.Exception (bracketOnError, throwIO) -import Control.Exception (IOException, try) +import Control.Exception (IOException, bracketOnError, + throwIO, try) import Control.Monad (void, when) import qualified Data.CaseInsensitive as CI -import qualified Data.Conduit.LogFile as LogFile import Data.Conduit.LogFile (RotatingLog) +import qualified Data.Conduit.LogFile as LogFile import Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker, monitorProcess, terminateMonitoredProcess) @@ -68,7 +68,7 @@ } newtype RunningBackgroundApp = RunningBackgroundApp - { rbaProcess :: MonitoredProcess + { rbaProcess :: MonitoredProcess } unpackBundle :: AppStartConfig diff --git a/Keter/HostManager.hs b/Keter/HostManager.hs --- a/Keter/HostManager.hs +++ b/Keter/HostManager.hs @@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} module Keter.HostManager ( -- * Types diff --git a/Keter/LabelMap.hs b/Keter/LabelMap.hs --- a/Keter/LabelMap.hs +++ b/Keter/LabelMap.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} module Keter.LabelMap ( -- * Types LabelMap @@ -68,24 +66,22 @@ | Static !(LabelTree a) | Wildcard !(LabelEntry a) | WildcardExcept !(LabelEntry a) !(LabelTree a) - deriving (Show) + deriving (Show, Eq) -- | Indicates whether a given label in the data LabelEntry a = Assigned !a !(LabelMap a) | Unassigned !(LabelMap a) + deriving Eq instance Show (LabelEntry a) where show (Assigned _ m) = "Assigned _ (" ++ show m ++ ")" show (Unassigned m) = "Unassigned (" ++ show m ++ ")" hostToLabels :: ByteString -> [ByteString] -hostToLabels h = - if BS.null h - then [] - else - if BS.last h == '.' - then drop 1 $ labels - else labels +hostToLabels h + | BS.null h = [] + | BS.last h == '.' = drop 1 labels + | otherwise = labels where labels = reverse . BS.split '.' $ h lemap :: (LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a @@ -163,7 +159,7 @@ case Map.null (Map.filter p t) of True -> EmptyLabelMap False -> m - where + where p (Unassigned EmptyLabelMap) = False p _ = True @@ -195,7 +191,13 @@ deleteTree _ EmptyLabelMap = EmptyLabelMap deleteTree ["*"] (Static t) = Static t -deleteTree [l] (Static t) = cleanup $ Static (Map.delete (CI.mk l) t) +deleteTree [l] (Static t) = cleanup $ Static m + where + m = case l' `Map.lookup` t of + Just (Assigned _ EmptyLabelMap) -> Map.delete l' t + Just (Assigned _ b) -> Map.insert l' (Unassigned b) (Map.delete l' t) + _ -> t + l' = CI.mk l deleteTree ["*"] (Wildcard w) = cleanup $ Wildcard (Unassigned (labelEntryMap w)) deleteTree [_] (Wildcard w) = Wildcard w @@ -218,7 +220,7 @@ deleteTree (l:ls) (WildcardExcept w t) = cleanup $ case Map.lookup l' t of Nothing -> WildcardExcept w t - Just le -> WildcardExcept w (Map.insert l' (lemap (deleteTree ls) le) t) + Just le -> WildcardExcept w (Map.insert l' (lemap (deleteTree ls) le) t) where l' = CI.mk l @@ -251,7 +253,7 @@ lookupTree (_:ls) (Wildcard w) = lookupTree ls $ labelEntryMap w lookupTree (l:ls) (WildcardExcept w t) = case Map.lookup (CI.mk l) t of - Just le -> + Just le -> case lookupTree ls $ labelEntryMap le of Just e -> Just e Nothing -> lookupTree ls $ labelEntryMap w @@ -263,7 +265,7 @@ -- will return true for precisely *.example.com, but not foo.example.com. -- -- This is so that different keter applications may establish ownership --- over different subdomains, including exceptions to a wildcard. +-- over different subdomains, including exceptions to a wildcard. -- -- This function *does not* test whether or not a given input would -- resolve to an existing host. In the above example, given only an diff --git a/Keter/Main.hs b/Keter/Main.hs --- a/Keter/Main.hs +++ b/Keter/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -46,7 +45,7 @@ import Control.Monad (void, when) import Data.Default (def) import Prelude hiding (FilePath, log) -import Filesystem (listDirectory, createTree) +import Filesystem (createTree) keter :: FilePath -- ^ root directory or config file -> [FilePath -> IO Plugin] @@ -128,7 +127,7 @@ launchInitial :: KeterConfig -> AppMan.AppManager -> IO () launchInitial kc@KeterConfig {..} appMan = do createTree incoming - bundles0 <- fmap (filter isKeter) $ listDirectory incoming + bundles0 <- fmap (filter isKeter) $ listDirectoryTree incoming mapM_ (AppMan.addApp appMan) bundles0 unless (V.null kconfigBuiltinStanzas) $ AppMan.perform @@ -148,7 +147,7 @@ startWatching kc@KeterConfig {..} appMan log = do -- File system watching wm <- FSN.startManager - _ <- FSN.watchDir wm incoming (const True) $ \e -> do + _ <- FSN.watchTree wm incoming (const True) $ \e -> do e' <- case e of FSN.Removed fp _ -> do @@ -166,13 +165,25 @@ -- Install HUP handler for cases when inotify cannot be used. void $ flip (installHandler sigHUP) Nothing $ Catch $ do - bundles <- fmap (filter isKeter) $ F.listDirectory incoming + bundles <- fmap (filter isKeter) $ listDirectoryTree incoming newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do time <- modificationTime <$> getFileStatus (F.encodeString bundle) return (getAppname bundle, (bundle, time)) AppMan.reloadAppList appMan newMap where incoming = getIncoming kc + +listDirectoryTree :: FilePath -> IO [FilePath] +listDirectoryTree fp = do + dir <- F.listDirectory fp + concat <$> mapM (\fp1 -> do + isDir <- F.isDirectory fp1 + if isDir + then + listDirectoryTree fp1 + else + return [fp1] + ) dir startListening :: KeterConfig -> HostMan.HostManager -> IO () startListening KeterConfig {..} hostman = do diff --git a/Keter/Plugin/Postgres.hs b/Keter/Plugin/Postgres.hs --- a/Keter/Plugin/Postgres.hs +++ b/Keter/Plugin/Postgres.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} module Keter.Plugin.Postgres ( -- * Settings Settings diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,14 +14,14 @@ ## Quick Start -Do get Keter up-and-running quickly on an Ubuntu system, run: +To get Keter up-and-running quickly on an Ubuntu system, run: wget -O - https://raw.githubusercontent.com/snoyberg/keter/master/setup-keter.sh | bash (Note: you may need to run the above command twice, if the shell exits after `apt-get` but before running the rest of its instructions.) This will download and build Keter from source and get it running with a -default configuration. By default Keter will be set up to also support HTTPS, and +default configuration. By default Keter will be set up to support HTTPS and will require you to provide a key and certificate in `/opt/keter/etc`. You can disable HTTPS in `/opt/keter/etc/keter-config.yaml` by commenting the certificate and key lines. @@ -112,8 +112,8 @@ `config/keter.yaml`. A sample file is available at https://github.com/snoyberg/keter/blob/master/incoming/foo1_0/config/keter.yaml. -Keter as well supports wildcard subdomains and exceptions, as in this example -configuration: +Keter also supports wildcard subdomains and exceptions, as in this +example configuration: ```yaml exec: ../com.example.app @@ -168,7 +168,9 @@ ## PostgreSQL support -Keter ships by default with a PostgreSQL plugin, which will handle management of PostgreSQL databases for your application. To use this, make the following changes: +Keter ships by default with a PostgreSQL plugin, which will handle +management of PostgreSQL databases for your application. To use this, +make the following changes: * Add the following lines to your `config/keter.yaml` file: @@ -229,7 +231,11 @@ * https://github.com/snoyberg/keter/blob/master/incoming/foo1_0/config/keter.yaml ## Multiple SSL Certificates -Keter is able to serve different certificates for different hosts, allowing for the deployment of distinct domains using the same server. An example `keter-config.yaml` would look like:: + +Keter is able to serve different certificates for different hosts, +allowing for the deployment of distinct domains using the same +server. An example `keter-config.yaml` would look like:: + ``` root: .. listeners: @@ -242,11 +248,13 @@ key: key.pem certificate: certificate2.pem ``` + ## FAQ + * Keter spawns multiple failing process when run with `sudo start keter`. * This may be due to Keter being unable to find the SSL certificate and key. Try to run `sudo /opt/keter/bin/keter /opt/keter/etc/keter-config.yaml`. If it fails with `keter: etc/certificate.pem: openBinaryFile: does not exist` or something like it, you may need to provide valid SSL certificates and keys - or disable HTTPS, by uncommenting the key and certificate lines from + or disable HTTPS, by uncommenting the key and certificate lines from `/opt/keter/etc/keter-config.yaml`. diff --git a/incoming/foo/hello.hs b/incoming/foo/hello.hs deleted file mode 100644 --- a/incoming/foo/hello.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -import System.Environment -import qualified Data.ByteString.Lazy.Char8 as L8 -import Network.Wai -import Network.Wai.Handler.Warp -import Network.HTTP.Types -import System.Directory -import Control.Monad.IO.Class -import System.IO -import Network.Wai.Middleware.RequestLogger -import Data.Default - -main :: IO () -main = do - fp <- canonicalizePath "." - [msg] <- getArgs - portS <- getEnv "PORT" - env <- getEnvironment - let port = read portS - logger <- mkRequestLogger def - { outputFormat = Apache FromHeader - } - run port $ logger $ \req -> do - liftIO $ putStrLn $ "Received a request at: " ++ show (pathInfo req) - liftIO $ hFlush stdout - liftIO $ hPutStrLn stderr $ "Testing standard error" - liftIO $ hFlush stderr - return $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack $ unlines - $ ("Message: " ++ msg) - : ("Path: " ++ fp) - : ("Headers: " ++ show (requestHeaders req)) - : map (\(k, v) -> concat - [ "Env: " - , k - , " = " - , v - ]) env diff --git a/keter.cabal b/keter.cabal --- a/keter.cabal +++ b/keter.cabal @@ -1,5 +1,5 @@ Name: keter -Version: 1.3.7.1 +Version: 1.3.8 Synopsis: Web application deployment manager, focusing on Haskell web frameworks Description: Hackage documentation generation is not reliable. For up to date documentation, please see: . Homepage: http://www.yesodweb.com/ @@ -61,6 +61,9 @@ , stm >= 2.4 , async , lifted-base + if impl(ghc < 7.6) + build-depends: + ghc-prim Exposed-Modules: Keter.Plugin.Postgres Keter.Types Keter.Types.V04 @@ -89,22 +92,6 @@ ghc-options: -threaded -Wall other-modules: Paths_keter -Executable hello - Main-is: hello.hs - hs-source-dirs: incoming/foo - Build-depends: base - , keter - , warp - , wai - , wai-extra - , http-types - , bytestring - , directory - , data-default - , transformers - ghc-options: -threaded -Wall - buildable: False - test-suite test hs-source-dirs: test main-is: Spec.hs @@ -116,6 +103,7 @@ , hspec >= 1.3 , unix , keter + , HUnit ghc-options: -Wall -threaded source-repository head