keter 1.3.7.1 → 1.3.8
raw patch · 10 files changed
+60/−90 lines, 10 filesdep +HUnitdep +ghc-primdep ~basedep ~processdep ~waiPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, ghc-prim
Dependency ranges changed: base, process, wai, wai-extra
API changes (from Hackage documentation)
+ Keter.LabelMap: instance Eq a => Eq (LabelEntry a)
+ Keter.LabelMap: instance Eq a => Eq (LabelMap a)
Files
- Data/Conduit/LogFile.hs +0/−1
- Data/Conduit/Process/Unix.hs +3/−1
- Keter/App.hs +4/−4
- Keter/HostManager.hs +0/−2
- Keter/LabelMap.hs +17/−15
- Keter/Main.hs +16/−5
- Keter/Plugin/Postgres.hs +0/−1
- README.md +15/−7
- incoming/foo/hello.hs +0/−37
- keter.cabal +5/−17
Data/Conduit/LogFile.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} module Data.Conduit.LogFile ( RotatingLog , openRotatingLog
Data/Conduit/Process/Unix.hs view
@@ -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__ (..))
Keter/App.hs view
@@ -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
Keter/HostManager.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} module Keter.HostManager ( -- * Types
Keter/LabelMap.hs view
@@ -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
Keter/Main.hs view
@@ -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
Keter/Plugin/Postgres.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-} module Keter.Plugin.Postgres ( -- * Settings Settings
README.md view
@@ -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`.
− incoming/foo/hello.hs
@@ -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
keter.cabal view
@@ -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: <http://www.stackage.org/package/keter>. 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