keter 2.0.1 → 2.1.0

raw patch · 17 files changed

+852/−862 lines, 17 filesdep +fast-loggerdep +monad-loggerdep +unliftio-coredep ~unix-compatPVP ok

version bump matches the API change (PVP)

Dependencies added: fast-logger, monad-logger, unliftio-core

Dependency ranges changed: unix-compat

API changes (from Hackage documentation)

Files

• ChangeLog.md +34/−0
• README.md +9/−46
• keter.cabal +9/−4
• src/Keter/App.hs +218/−189
• src/Keter/AppManager.hs +94/−70
• src/Keter/Cli.hs +38/−25
• src/Keter/Common.hs +0/−113
• src/Keter/Conduit/LogFile.hs +0/−140
• src/Keter/Conduit/Process/Unix.hs +53/−47
• src/Keter/Config/V10.hs +7/−3
• src/Keter/Context.hs +28/−0
• src/Keter/HostManager.hs +62/−39
• src/Keter/Logger.hs +59/−0
• src/Keter/Main.hs +141/−112
• src/Keter/PortPool.hs +20/−11
• src/Keter/Proxy.hs +58/−51
• test/Spec.hs +22/−12

@@ -1,3 +1,37 @@+## 2.1++Please reference `MigrationGuide-2.1.md` for in-depth documentation on breaking changes to be aware of, examples of said changes, and potential solutions/workarounds for them if you plan on upgrading to this version of `keter`.+++ Log naming and directory scheme has changed for both main keter logs and app logs.  +  Old logs were named `dir/current.log` for the current log and `%Y%m%d_%H%M%S.log` +  (`time` package conventions) for rotated logs.  +  Current logs have been brought up one level and named after their old directory:  +  `logs/keter/current.log` -> `logs/keter.log`  +  Rotated logs will now simply have `.1` `.2` ascending appended to the name of the base logs +  rather than be named after the date and time they were rotated at:  +  `logs/keter/20230413_231415.log` -> `logs/keter.log.1`  +  `logs/__builtin__/20230413_231415.log` -> `logs/__builtin__.log.1`  +  `logs/app-foo/20230413_231415.log` -> `logs/app-foo.log.1`  +  Please update anything that depended on the old log naming and directory conventions accordingly.++ Added the `rotate-logs` option (default: true) in the keter config file.  +  When true, the main keter (non-app!) logs will rotate like they have in previous versions.  +  When false, the main keter logs will emit straight to stderr; this is useful e.g. if you're +  running keter via systemd, which captures stderr output for you.++ Internal logging implementation has been switched over to `fast-logger` instead of the+  old in-house logging solution.  +  Please be aware that compared to the old logging solution, the usage of `fast-logger` does+  not 100% guarantee consistent time ordering. If anything previously depended on tailing the last+  line of a log and critically assumed that messages will be in order, it should now parse via +  timestamp instead.++ The `LogMessage` ADT has been removed.++ Replaced individual logging calls with TH splice -style calls where sensible to have access to source location info.++ Updated log message format to make use of the additional info:  +  `"$time|$module$:$line_num|$log_level> $msg"`++ Added `Keter.Context`, exposing the new `KeterM` monad and related functions.  +  This monad carries a mappable global config and logger around, eliminating the need to pass various configuration data and the logger to everything.++ Refactored most `Keter.*` module functions to be actions in `KeterM`  +  Please anticipate breaking changes for anything written against the exposed API.+ ## 2.0.1  + Force usage of http-reverse-proxy versions above 0.6.0.1.

@@ -8,7 +8,6 @@ * Provides SSL support if requested. * Automatically launches applications, monitors processes, and relaunches any processes which die. * Provides graceful redeployment support, by launching a second copy of your application, performing a health check[1], and then switching reverse proxying to the new process.-* Management of log files.  Keter provides many more advanced features and extension points. It allows configuration of static hosts, redirect rules, management of PostgreSQL@@ -152,6 +151,11 @@      sudo mkdir -p /opt/keter/incoming     sudo chown $USER /opt/keter/incoming++Additionally, you may want to enable logging to stderr by disabling `rotate-logs` in `config/keter.yaml`, since systemd will automatically capture and manage stderr output for you:++    rotate-logs: false+ ---     For versions of Ubuntu and derivatives less than 15.04, configure an Upstart job. @@ -174,54 +178,13 @@   ### NixOS -Add a nix file `keter.nix` that fetches this repository and imports-the module file:-```nix-let-  owner = "snoyberg";-  repo = "keter";-  rev = "be4e3132e988519dacd0f9b40a47e23d33865b76"; -  src = builtins.fetchTarball {-    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz";-    };-in-import "${src}/nix/module.nix"-```-Make sure to update rev to the latest commit!-Now you can import this as an ordinary module-in your `configuration.nix`:-```nix-imports = [-  ./keter.nix-];-```--Now you can configure keter in the same `configuration.nix`:-```nix-services.keter = {-  enable = true;-  keterPackage = pkgs.keter;-  bundle = {-    domain = "example.com";-    secretScript = env.secretScript;-    publicScript = env.publicScript;-    package = myWebAppDerivation;-    executable = "exe";-  };-};-```+Keter is integrated within nixos: -secretScript is used to load environment varialbes, for example:-```-MY_AWS_KEY=$(cat /run/keys/AWS_ACCESS_KEY_ID)-```-Public script does the same but emits the loading to the logs.-which isn't good for secrets.+https://search.nixos.org/options?channel=22.11&show=services.keter.keterPackage&from=0&size=50&sort=relevance&type=packages&query=keter -For the full option list available see `nix/module.nix`.-This should load most webapps but PR's for improved support are welcome.-Note that the default expects keter to be run behind nginx.+There is an example that integrates yesod into keter with NixOS here:+https://github.com/jappeace/yesod-keter-nix      ## Bundles 

@@ -1,6 +1,6 @@ Cabal-version:       >=1.10 Name:                keter-Version:             2.0.1+Version:             2.1.0 Synopsis:            Web application deployment manager, focusing on Haskell web frameworks Description:     Deployment system for web applications, originally intended for hosting Yesod@@ -10,7 +10,6 @@     * Provides SSL support if requested.     * Automatically launches applications, monitors processes, and relaunches any processes which die.     * Provides graceful redeployment support, by launching a second copy of your application, performing a health check, and then switching reverse proxying to the new process.-    * Management of log files.     .     Keter provides many more advanced features and extension points. It allows configuration of static hosts, redirect rules, management of PostgreSQL databases, and more. It supports a simple bundle format for applications which allows for easy management of your web apps. @@ -49,7 +48,7 @@                      , template-haskell                      , blaze-builder             >= 0.3           && < 0.5                      , yaml                      >= 0.8.4         && < 0.12-                     , unix-compat               >= 0.3           && < 0.6+                     , unix-compat               >= 0.3           && < 0.7                      , conduit                   >= 1.1                      , conduit-extra             >= 1.1                      , http-reverse-proxy        >= 0.6.0.1       && < 0.7@@ -62,6 +61,9 @@                      , attoparsec                >= 0.10                      , http-client               >= 0.5.0                      , http-conduit              >= 2.1+                     , fast-logger               < 3.3+                     , monad-logger              < 0.4+                     , unliftio-core             < 0.3                      , case-insensitive                      , array                      , mtl@@ -95,6 +97,7 @@                        Keter.AppManager                        Keter.LabelMap                        Keter.Cli+                       Keter.Context                        Keter.Main                        Keter.PortPool                        Keter.Proxy@@ -102,7 +105,7 @@                        Keter.Rewrite                        Keter.Yaml.FilePath                        Keter.TempTarball-                       Keter.Conduit.LogFile+                       Keter.Logger                        Keter.Conduit.Process.Unix   Other-Modules:                        Keter.Aeson.KeyHelper@@ -124,6 +127,8 @@     type: exitcode-stdio-1.0     build-depends:   base                    , transformers+                   , mtl+                   , monad-logger                    , conduit                    , bytestring                    , unix

@@ -4,6 +4,8 @@ {-# LANGUAGE TemplateHaskell     #-} {-# LANGUAGE TupleSections       #-} {-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}  module Keter.App     ( App@@ -16,8 +18,10 @@     ) where  import Keter.Common+import Keter.Context import           Data.Set                   (Set) import           Data.Text                  (Text)+import           Data.ByteString            (ByteString) import           System.FilePath            (FilePath) import           Data.Map                   (Map) import           Keter.Rewrite (ReverseProxyConfig (..))@@ -26,12 +30,17 @@ import           Control.Arrow             ((***)) import           Control.Concurrent        (forkIO, threadDelay) import           Control.Concurrent.STM-import           Control.Exception         (IOException, bracketOnError,+import           Control.Exception         (IOException, SomeException,+                                            bracketOnError,                                             throwIO, try, catch) import           Control.Monad             (void, when, liftM)+import           Control.Monad.IO.Class    (liftIO)+import           Control.Monad.IO.Unlift   (withRunInIO)+import           Control.Monad.Logger      +import           Control.Monad.Reader      (ask) import qualified Data.CaseInsensitive      as CI-import           Keter.Conduit.LogFile      (RotatingLog)-import qualified Keter.Conduit.LogFile      as LogFile+import           Keter.Logger              (Logger)+import qualified Keter.Logger              as Log import           Keter.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,                                             monitorProcess,                                             terminateMonitoredProcess, printStatus)@@ -49,7 +58,8 @@ import           Keter.Yaml.FilePath import System.FilePath ((</>)) import           System.Directory          (canonicalizePath, doesFileExist,-                                            removeDirectoryRecursive)+                                            removeDirectoryRecursive,+                                            createDirectoryIfMissing) import           Keter.HostManager         hiding (start) import           Keter.PortPool            (PortPool, getPort, releasePort) import           Keter.Config@@ -57,6 +67,7 @@ import           Prelude                   hiding (FilePath) import           System.Environment        (getEnvironment) import           System.IO                 (hClose, IOMode(..))+import qualified System.Log.FastLogger  as FL import           System.Posix.Files        (fileAccess) import           System.Posix.Types        (EpochTime, GroupID, UserID) import           System.Timeout            (timeout)@@ -70,7 +81,7 @@     , appHosts          :: !(TVar (Set Host))     , appDir            :: !(TVar (Maybe FilePath))     , appAsc            :: !AppStartConfig-    , appRlog           :: !(TVar (Maybe RotatingLog))+    , appLog           :: !(TVar (Maybe Logger))     } instance Show App where   show App {appId, ..} = "App{appId=" <> show appId <> "}"@@ -99,13 +110,13 @@     { rbaProcess :: MonitoredProcess     } -unpackBundle :: AppStartConfig-             -> FilePath+unpackBundle :: FilePath              -> AppId-             -> IO (FilePath, BundleConfig)-unpackBundle AppStartConfig {..} bundle aid = do-    ascLog $ UnpackingBundle bundle-    unpackTempTar (fmap snd ascSetuid) ascTempFolder bundle folderName $ \dir -> do+             -> KeterM AppStartConfig (FilePath, BundleConfig)+unpackBundle bundle aid = do+    AppStartConfig{..} <- ask+    $logInfo $ pack $ "Unpacking bundle '" <> show bundle <> "'"+    liftIO $ unpackTempTar (fmap snd ascSetuid) ascTempFolder bundle folderName $ \dir -> do         -- Get the FilePath for the keter yaml configuration. Tests for         -- keter.yml and defaults to keter.yaml.         configFP <- do@@ -133,36 +144,36 @@     , ascHostManager    :: !HostManager     , ascPortPool       :: !PortPool     , ascPlugins        :: !Plugins-    , ascLog            :: !(LogMessage -> IO ())     , ascKeterConfig    :: !KeterConfig     } -withConfig :: AppStartConfig-           -> AppId+withConfig :: AppId            -> AppInput-           -> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> IO a)-           -> IO a-withConfig _asc _aid (AIData bconfig) f = f Nothing bconfig Nothing-withConfig asc aid (AIBundle fp modtime) f = bracketOnError-    (unpackBundle asc fp aid)-    (\(newdir, _) -> removeDirectoryRecursive newdir)-    $ \(newdir, bconfig) -> f (Just newdir) bconfig (Just modtime)+           -> (Maybe FilePath -> BundleConfig -> Maybe EpochTime -> KeterM AppStartConfig a)+           -> KeterM AppStartConfig a+withConfig _aid (AIData bconfig) f = f Nothing bconfig Nothing+withConfig aid (AIBundle fp modtime) f = do+    withRunInIO $ \rio ->+        bracketOnError (rio $ unpackBundle fp aid) (\(newdir, _) -> removeDirectoryRecursive newdir) $ \(newdir, bconfig) -> +            rio $ f (Just newdir) bconfig (Just modtime) -withReservations :: AppStartConfig-                 -> AppId+withReservations :: AppId                  -> BundleConfig-                 -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a)-                 -> IO a-withReservations asc aid bconfig f = withActions asc bconfig $ \wacs backs actions -> bracketOnError-    (reserveHosts (ascLog asc) (ascHostManager asc) aid $ Map.keysSet actions)-    (forgetReservations (ascLog asc) (ascHostManager asc) aid)-    (const $ f wacs backs actions)+                 -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> KeterM AppStartConfig a)+                 -> KeterM AppStartConfig a+withReservations aid bconfig f = do+    AppStartConfig{..} <- ask+    withActions bconfig $ \wacs backs actions ->+        withRunInIO $ \rio ->+            bracketOnError+              (rio $ withMappedConfig (const ascHostManager) $ reserveHosts aid $ Map.keysSet actions)+              (\rsvs -> rio $ withMappedConfig (const ascHostManager)  $ forgetReservations aid rsvs)+              (\_ -> rio $ f wacs backs actions) -withActions :: AppStartConfig-            -> BundleConfig-            -> ([ WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a)-            -> IO a-withActions asc bconfig f =+withActions :: BundleConfig+            -> ([ WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> KeterM AppStartConfig a)+            -> KeterM AppStartConfig a+withActions bconfig f =     loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty   where     -- todo: add loading from relative location@@ -172,20 +183,23 @@     loadCert _ = return mempty      loop [] wacs backs actions = f wacs backs actions-    loop (Stanza (StanzaWebApp wac) rs:stanzas) wacs backs actions = bracketOnError-        (getPort (ascLog asc) (ascPortPool asc) >>= either throwIO-             (\p -> fmap (p,) <$> loadCert $ waconfigSsl wac)-        )-        (\(port, _)    -> releasePort (ascPortPool asc) port)-        (\(port, cert) -> loop-            stanzas-            (wac { waconfigPort = port } : wacs)-            backs-            (Map.unions $ actions : map (\host -> Map.singleton host ((PAPort port (waconfigTimeout wac), rs), cert)) hosts))+    loop (Stanza (StanzaWebApp wac) rs:stanzas) wacs backs actions = do+      AppStartConfig{..} <- ask+      withRunInIO $ \rio -> +        liftIO $ bracketOnError+          (rio (getPort ascPortPool) >>= either throwIO+               (\p -> fmap (p,) <$> loadCert $ waconfigSsl wac)+          )+          (\(port, _)    -> releasePort ascPortPool port)+          (\(port, cert) -> rio $ loop+              stanzas+              (wac { waconfigPort = port } : wacs)+              backs+              (Map.unions $ actions : map (\host -> Map.singleton host ((PAPort port (waconfigTimeout wac), rs), cert)) hosts))       where         hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)     loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 = do-        cert <- loadCert $ sfconfigSsl sfc+        cert <- liftIO $ loadCert $ sfconfigSsl sfc         loop stanzas wacs backs (actions cert)       where         actions cert = Map.unions@@ -193,7 +207,7 @@                 : map (\host -> Map.singleton host ((PAStatic sfc, rs), cert))                   (Set.toList (sfconfigHosts sfc))     loop (Stanza (StanzaRedirect red) rs:stanzas) wacs backs actions0 = do-        cert <- loadCert $ redirconfigSsl red+        cert <- liftIO $ loadCert $ redirconfigSsl red         loop stanzas wacs backs (actions cert)       where         actions cert = Map.unions@@ -201,40 +215,39 @@                 : map (\host -> Map.singleton host ((PARedirect red, rs), cert))                   (Set.toList (redirconfigHosts red))     loop (Stanza (StanzaReverseProxy rev mid to) rs:stanzas) wacs backs actions0 = do-        cert <- loadCert $ reversingUseSSL rev+        cert <- liftIO $ loadCert $ reversingUseSSL rev         loop stanzas wacs backs (actions cert)       where         actions cert = Map.insert (CI.mk $ reversingHost rev) ((PAReverseProxy rev mid to, rs), cert) actions0     loop (Stanza (StanzaBackground back) _:stanzas) wacs backs actions =         loop stanzas wacs (back:backs) actions -withRotatingLog :: AppStartConfig-                -> AppId-                -> Maybe (TVar (Maybe RotatingLog))-                -> ((TVar (Maybe RotatingLog)) -> RotatingLog -> IO a)-                -> IO a-withRotatingLog asc aid Nothing f = do-    var <- newTVarIO Nothing-    withRotatingLog asc aid (Just var) f-withRotatingLog AppStartConfig {..} aid (Just var) f = do-    mrlog <- readTVarIO var-    case mrlog of-        Nothing -> bracketOnError-            (LogFile.openRotatingLog dir LogFile.defaultMaxTotal)-            LogFile.close-            (f var)-        Just rlog ->  f var rlog+-- | Gives the log file or log tag name for a given 'AppId'+appLogName :: AppId -> String+appLogName AIBuiltin = "__builtin__"+appLogName (AINamed x) = "app-" <> unpack x++withLogger :: AppId+           -> Maybe (TVar (Maybe Logger))+           -> ((TVar (Maybe Logger)) -> Logger -> KeterM AppStartConfig a)+           -> KeterM AppStartConfig a+withLogger aid Nothing f = do+    var <- liftIO $ newTVarIO Nothing+    withLogger aid (Just var) f+withLogger aid (Just var) f = do+    AppStartConfig{..} <- ask+    mappLogger <- liftIO $ readTVarIO var+    case mappLogger of+        Nothing -> withRunInIO $ \rio -> +          bracketOnError (Log.createLoggerViaConfig ascKeterConfig (appLogName aid)) Log.loggerClose (rio . f var)+        Just appLogger ->  f var appLogger   where-    dir = kconfigDir ascKeterConfig </> "log" </> name-    name =-        case aid of-            AIBuiltin -> "__builtin__"-            AINamed x -> unpack $ "app-" <> x -withSanityChecks :: AppStartConfig -> BundleConfig -> IO a -> IO a-withSanityChecks AppStartConfig {..} BundleConfig {..} f = do-    V.mapM_ go bconfigStanzas-    ascLog SanityChecksPassed+withSanityChecks :: BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a+withSanityChecks BundleConfig{..} f = do+    cfg@AppStartConfig{..} <- ask+    liftIO $ V.mapM_ go bconfigStanzas+    $logInfo "Sanity checks passed"     f   where     go (Stanza (StanzaWebApp WebAppConfig {..}) _) = do@@ -254,20 +267,21 @@                     else throwIO $ FileNotExecutable fp             else throwIO $ ExecutableNotFound fp -start :: AppStartConfig-      -> AppId+start :: AppId       -> AppInput-      -> IO App-start asc aid input =-    withRotatingLog asc aid Nothing $ \trlog rlog ->-    withConfig asc aid input $ \newdir bconfig mmodtime ->-    withSanityChecks asc bconfig $-    withReservations asc aid bconfig $ \webapps backs actions ->-    withBackgroundApps asc aid bconfig newdir rlog backs $ \runningBacks ->-    withWebApps asc aid bconfig newdir rlog webapps $ \runningWebapps -> do-        mapM_ ensureAlive runningWebapps-        activateApp (ascLog asc) (ascHostManager asc) aid actions-        App+      -> KeterM AppStartConfig App+start aid input =+    withLogger aid Nothing $ \tAppLogger appLogger ->+    withConfig aid input $ \newdir bconfig mmodtime ->+    withSanityChecks bconfig $+    withReservations aid bconfig $ \webapps backs actions ->+    withBackgroundApps aid bconfig newdir appLogger backs $ \runningBacks ->+    withWebApps aid bconfig newdir appLogger webapps $ \runningWebapps -> do+        asc@AppStartConfig{..} <- ask+        liftIO $ mapM_ ensureAlive runningWebapps+        withMappedConfig (const ascHostManager) $ activateApp aid actions+        liftIO $ +          App             <$> newTVarIO mmodtime             <*> newTVarIO runningWebapps             <*> newTVarIO runningBacks@@ -275,7 +289,7 @@             <*> newTVarIO (Map.keysSet actions)             <*> newTVarIO newdir             <*> return asc-            <*> return trlog+            <*> return tAppLogger  bracketedMap :: (a -> (b -> IO c) -> IO c)              -> ([b] -> IO c)@@ -287,30 +301,35 @@     loop front [] = inside $ front []     loop front (c:cs) = with c $ \x -> loop (front . (x:)) cs -withWebApps :: AppStartConfig-            -> AppId+withWebApps :: AppId             -> BundleConfig             -> Maybe FilePath-            -> RotatingLog+            -> Logger             -> [WebAppConfig Port]-            -> ([RunningWebApp] -> IO a)-            -> IO a-withWebApps asc aid bconfig mdir rlog configs0 f =-    bracketedMap alloc f configs0+            -> ([RunningWebApp] -> KeterM AppStartConfig a)+            -> KeterM AppStartConfig a+withWebApps aid bconfig mdir appLogger configs0 f =+    withRunInIO $ \rio -> +      bracketedMap (\wac f -> rio $ alloc wac (liftIO <$> f)) (rio . f) configs0   where-    alloc = launchWebApp asc aid bconfig mdir rlog+    alloc = launchWebApp aid bconfig mdir appLogger -launchWebApp :: AppStartConfig-             -> AppId+-- | Format a log message for an app by tagging it with 'app-$name>' (only when it is being logged to stderr)+formatAppLog :: AppId -> FL.LogType -> LogStr -> LogStr+formatAppLog aid (FL.LogStderr _) msg = toLogStr (appLogName aid) <> "> " <> msg+formatAppLog _ _ msg = msg++launchWebApp :: AppId              -> BundleConfig              -> Maybe FilePath-             -> RotatingLog+             -> Logger              -> WebAppConfig Port-             -> (RunningWebApp -> IO a)-             -> IO a-launchWebApp AppStartConfig {..} aid BundleConfig {..} mdir rlog WebAppConfig {..} f = do-    otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins-    forwardedEnv <- getForwardedEnv waconfigForwardEnv+             -> (RunningWebApp -> KeterM AppStartConfig a)+             -> KeterM AppStartConfig a+launchWebApp aid BundleConfig {..} mdir appLogger WebAppConfig {..} f = do+    AppStartConfig{..} <- ask+    otherEnv <- liftIO $ pluginsGetEnv ascPlugins name bconfigPlugins+    forwardedEnv <- liftIO $ getForwardedEnv waconfigForwardEnv     let httpPort  = kconfigExternalHttpPort  ascKeterConfig         httpsPort = kconfigExternalHttpsPort ascKeterConfig         (scheme, extport) =@@ -327,20 +346,20 @@             , Map.singleton "PORT" $ pack $ show waconfigPort             , Map.singleton "APPROOT" $ scheme <> CI.original waconfigApprootHost <> pack extport             ]-    exec <- canonicalizePath waconfigExec-    bracketOnError-        (monitorProcess-            (ascLog . OtherMessage . decodeUtf8With lenientDecode)+    exec <- liftIO $ canonicalizePath waconfigExec+    mainLogger <- askLoggerIO+    withRunInIO $ \rio -> bracketOnError+        (rio $ monitorProcess             ascProcessTracker             (encodeUtf8 . fst <$> ascSetuid)             (encodeUtf8 $ pack exec)             (maybe "/tmp" (encodeUtf8 . pack) mdir)             (map encodeUtf8 $ V.toList waconfigArgs)             (map (encodeUtf8 *** encodeUtf8) env)-            (LogFile.addChunk rlog)+            (Log.loggerLog appLogger . formatAppLog aid (Log.loggerType appLogger) . toLogStr)             (const $ return True))         terminateMonitoredProcess-        $ \mp -> f RunningWebApp+        $ \mp -> rio $ f RunningWebApp             { rwaProcess = mp             , rwaPort = waconfigPort             , rwaEnsureAliveTimeOut = fromMaybe (90 * 1000 * 1000) waconfigEnsureAliveTimeout@@ -351,11 +370,11 @@             AIBuiltin -> "__builtin__"             AINamed x -> x -killWebApp :: (LogMessage -> IO ()) -> RunningWebApp -> IO ()-killWebApp asclog RunningWebApp {..} = do-    status <- printStatus rwaProcess-    asclog $ KillingApp rwaPort status-    terminateMonitoredProcess rwaProcess+killWebApp :: RunningWebApp -> KeterM cfg ()+killWebApp RunningWebApp {..} = do+    status <- liftIO $ printStatus rwaProcess+    $logInfo $ pack $ "Killing " <> unpack status <> " running on port: "  <> show rwaPort+    liftIO $ terminateMonitoredProcess rwaProcess  ensureAlive :: RunningWebApp -> IO () ensureAlive RunningWebApp {..} = do@@ -408,30 +427,29 @@                   tryIO m = catch (liftM Right m) (return . Left)  -withBackgroundApps :: AppStartConfig-                   -> AppId+withBackgroundApps :: AppId                    -> BundleConfig                    -> Maybe FilePath-                   -> RotatingLog+                   -> Logger                    -> [BackgroundConfig]-                   -> ([RunningBackgroundApp] -> IO a)-                   -> IO a-withBackgroundApps asc aid bconfig mdir rlog configs f =-    bracketedMap alloc f configs+                   -> ([RunningBackgroundApp] -> KeterM AppStartConfig a)+                   -> KeterM AppStartConfig a+withBackgroundApps aid bconfig mdir appLogger configs f =+    withRunInIO $ \rio -> bracketedMap (\cfg f -> rio $ alloc cfg (liftIO <$> f)) (rio . f) configs   where-    alloc = launchBackgroundApp asc aid bconfig mdir rlog+    alloc = launchBackgroundApp aid bconfig mdir appLogger -launchBackgroundApp :: AppStartConfig-                    -> AppId+launchBackgroundApp :: AppId                     -> BundleConfig                     -> Maybe FilePath-                    -> RotatingLog+                    -> Logger                      -> BackgroundConfig                     -> (RunningBackgroundApp -> IO a)-                    -> IO a-launchBackgroundApp AppStartConfig {..} aid BundleConfig {..} mdir rlog BackgroundConfig {..} f = do-    otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins-    forwardedEnv <- getForwardedEnv bgconfigForwardEnv+                    -> KeterM AppStartConfig a+launchBackgroundApp aid BundleConfig {..} mdir appLogger BackgroundConfig {..} f = do+    AppStartConfig{..} <- ask+    otherEnv <- liftIO $ pluginsGetEnv ascPlugins name bconfigPlugins+    forwardedEnv <- liftIO $ getForwardedEnv bgconfigForwardEnv     let env = Map.toList $ Map.unions             -- Order matters as in launchWebApp             [ bgconfigEnvironment@@ -439,7 +457,7 @@             , Map.fromList otherEnv             , kconfigEnvironment ascKeterConfig             ]-    exec <- canonicalizePath bgconfigExec+    exec <- liftIO $ canonicalizePath bgconfigExec      let delay = threadDelay $ fromIntegral $ bgconfigRestartDelaySeconds * 1000 * 1000     shouldRestart <-@@ -448,23 +466,22 @@                 delay                 return True             LimitedRestarts maxCount -> do-                icount <- newIORef 0+                icount <- liftIO $ newIORef 0                 return $ do                     res <- atomicModifyIORef icount $ \count ->                         (count + 1, count < maxCount)                     when res delay                     return res--    bracketOnError-        (monitorProcess-            (ascLog . OtherMessage . decodeUtf8With lenientDecode)+    mainLogger <- askLoggerIO+    withRunInIO $ \rio -> bracketOnError+        (rio $ monitorProcess             ascProcessTracker             (encodeUtf8 . fst <$> ascSetuid)             (encodeUtf8 $ pack exec)             (maybe "/tmp" (encodeUtf8 . pack) mdir)             (map encodeUtf8 $ V.toList bgconfigArgs)             (map (encodeUtf8 *** encodeUtf8) env)-            (LogFile.addChunk rlog)+            (Log.loggerLog appLogger . formatAppLog aid (Log.loggerType appLogger) . toLogStr)             (const shouldRestart))         terminateMonitoredProcess         (f . RunningBackgroundApp)@@ -489,7 +506,7 @@       -> (Maybe BundleConfig)       -> KIO () -- ^ action to perform to remove this App from list of actives       -> KIO (App, KIO ())-start tf muid processTracker portman plugins rlog appname bundle removeFromList = do+start tf muid processTracker portman plugins appLogger appname bundle removeFromList = do     Prelude.error "FIXME Keter.App.start"     chan <- newChan     return (App $ writeChan chan, rest chan)@@ -599,74 +616,86 @@         terminateOld = forkKIO $ do     -} -reload :: App -> AppInput -> IO ()-reload App {..} input =-    withRotatingLog appAsc appId (Just appRlog) $ \_ rlog ->-    withConfig appAsc appId input $ \newdir bconfig mmodtime ->-    withSanityChecks appAsc bconfig $-    withReservations appAsc appId bconfig $ \webapps backs actions ->-    withBackgroundApps appAsc appId bconfig newdir rlog backs $ \runningBacks ->-    withWebApps appAsc appId bconfig newdir rlog webapps $ \runningWebapps -> do-        mapM_ ensureAlive runningWebapps-        readTVarIO appHosts >>= reactivateApp (ascLog appAsc) (ascHostManager appAsc) appId actions-        (oldApps, oldBacks, oldDir, oldRlog) <- atomically $ do-            oldApps <- readTVar appRunningWebApps-            oldBacks <- readTVar appBackgroundApps-            oldDir <- readTVar appDir-            oldRlog <- readTVar appRlog+reload :: AppInput -> KeterM App ()+reload input = do+    App{..} <- ask+    withMappedConfig (const appAsc) $ +      withLogger appId (Just appLog) $ \_ appLogger ->+      withConfig appId input $ \newdir bconfig mmodtime ->+      withSanityChecks bconfig $+      withReservations appId bconfig $ \webapps backs actions ->+      withBackgroundApps appId bconfig newdir appLogger backs $ \runningBacks ->+      withWebApps appId bconfig newdir appLogger webapps $ \runningWebapps -> do+          liftIO $ mapM_ ensureAlive runningWebapps+          liftIO (readTVarIO appHosts) >>= \hosts ->+            withMappedConfig (const $ ascHostManager appAsc) $ +              reactivateApp appId actions hosts+          (oldApps, oldBacks, oldDir, oldRlog) <- liftIO $ atomically $ do+              oldApps <- readTVar appRunningWebApps+              oldBacks <- readTVar appBackgroundApps+              oldDir <- readTVar appDir+              oldRlog <- readTVar appLog -            writeTVar appModTime mmodtime-            writeTVar appRunningWebApps runningWebapps-            writeTVar appBackgroundApps runningBacks-            writeTVar appHosts $ Map.keysSet actions-            writeTVar appDir newdir-            return (oldApps, oldBacks, oldDir, oldRlog)-        void $ forkIO $ terminateHelper appAsc appId oldApps oldBacks oldDir oldRlog+              writeTVar appModTime mmodtime+              writeTVar appRunningWebApps runningWebapps+              writeTVar appBackgroundApps runningBacks+              writeTVar appHosts $ Map.keysSet actions+              writeTVar appDir newdir+              return (oldApps, oldBacks, oldDir, oldRlog)+          void $ withRunInIO $ \rio -> +            forkIO $ rio $ terminateHelper appId oldApps oldBacks oldDir oldRlog -terminate :: App -> IO ()-terminate App {..} = do-    (hosts, apps, backs, mdir, rlog) <- atomically $ do+terminate :: KeterM App ()+terminate = do+    App{..} <- ask+    let AppStartConfig {..} = appAsc+    (hosts, apps, backs, mdir, appLogger) <- liftIO $ atomically $ do         hosts <- readTVar appHosts         apps <- readTVar appRunningWebApps         backs <- readTVar appBackgroundApps         mdir <- readTVar appDir-        rlog <- readTVar appRlog+        appLogger <- readTVar appLog          writeTVar appModTime Nothing         writeTVar appRunningWebApps []         writeTVar appBackgroundApps []         writeTVar appHosts Set.empty         writeTVar appDir Nothing-        writeTVar appRlog Nothing+        writeTVar appLog Nothing -        return (hosts, apps, backs, mdir, rlog)+        return (hosts, apps, backs, mdir, appLogger) -    deactivateApp ascLog ascHostManager appId hosts-    void $ forkIO $ terminateHelper appAsc appId apps backs mdir rlog-    maybe (return ()) LogFile.close rlog-  where-    AppStartConfig {..} = appAsc+    withMappedConfig (const ascHostManager) $+        deactivateApp appId hosts -terminateHelper :: AppStartConfig-                -> AppId+    void $ withRunInIO $ \rio ->+      forkIO $ rio $ withMappedConfig (const appAsc) $ +        terminateHelper appId apps backs mdir appLogger+    liftIO $ maybe (return ()) Log.loggerClose appLogger++terminateHelper :: AppId                 -> [RunningWebApp]                 -> [RunningBackgroundApp]                 -> Maybe FilePath-                -> Maybe RotatingLog-                -> IO ()-terminateHelper AppStartConfig {..} aid apps backs mdir rlog = do-    threadDelay $ 20 * 1000 * 1000-    ascLog $ TerminatingOldProcess aid-    mapM_ (killWebApp ascLog) apps-    mapM_ killBackgroundApp backs-    threadDelay $ 60 * 1000 * 1000+                -> Maybe Logger+                -> KeterM AppStartConfig ()+terminateHelper aid apps backs mdir appLogger = do+    AppStartConfig{..} <- ask+    liftIO $ threadDelay $ 20 * 1000 * 1000+    $logInfo $ pack $ +        "Sending old process TERM signal: " +          ++ case aid of { AINamed t -> unpack t; AIBuiltin -> "builtin" }+    mapM_ killWebApp apps+    liftIO $ do +        mapM_ killBackgroundApp backs+        threadDelay $ 60 * 1000 * 1000     case mdir of         Nothing -> return ()         Just dir -> do-            ascLog $ RemovingOldFolder dir-            res <- try $ removeDirectoryRecursive dir+            $logInfo $ pack $ "Removing unneeded folder: " ++ dir+            res <- liftIO $ try @SomeException $ removeDirectoryRecursive dir             case res of-                Left e -> $logEx ascLog e+                Left e -> $logError $ pack $ show e                 Right () -> return ()  -- | Get the modification time of the bundle file this app was launched from,@@ -704,25 +733,25 @@                         let time = either (P.const 0) id etime                         return (Map.insert appname (app, time) appMap, return ())                     Nothing -> do-                        mlogger <- do+                        mappLogger <- do                             let dirout = kconfigDir </> "log" </> fromText ("app-" ++ appname)                                 direrr = dirout </> "err"-                            erlog <- liftIO $ LogFile.openRotatingLog+                            eappLogger <- liftIO $ Log.openRotatingLog                                 (F.encodeString dirout)-                                LogFile.defaultMaxTotal-                            case erlog of+                                Log.defaultMaxTotal+                            case eappLogger of                                 Left e -> do                                     $logEx e                                     return Nothing-                                Right rlog -> return (Just rlog)-                        let logger = fromMaybe LogFile.dummy mlogger+                                Right appLogger -> return (Just appLogger)+                        let appLogger = fromMaybe Log.dummy mappLogger                         (app, rest) <- App.start                             tf                             muid                             processTracker                             hostman                             plugins-                            logger+                            appLogger                             appname                             bundle                             (removeApp appname)

@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes        #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications   #-} -- | Used for management of applications. module Keter.AppManager     ( -- * Types@@ -18,6 +21,7 @@     ) where  import Keter.Common+import Keter.Context import           Data.Set                   (Set) import           Data.Text                  (Text) import           System.FilePath            (FilePath)@@ -29,6 +33,10 @@ import           Control.Concurrent.STM import qualified Control.Exception          as E import           Control.Monad              (void)+import           Control.Monad.IO.Class     (liftIO)+import           Control.Monad.IO.Unlift    (withRunInIO)+import           Control.Monad.Logger+import           Control.Monad.Reader       (ask) import           Data.Foldable              (fold) import qualified Data.Map                   as Map import           Data.Maybe                 (catMaybes, mapMaybe)@@ -49,7 +57,6 @@     { apps           :: !(TVar (Map AppId (TVar AppState)))     , appStartConfig :: !AppStartConfig     , mutex          :: !(MVar ())-    , log            :: !(LogMessage -> IO ())     }  data AppState = ASRunning App@@ -81,14 +88,13 @@ data Action = Reload AppInput | Terminate  deriving Show -initialize :: (LogMessage -> IO ())-           -> AppStartConfig-           -> IO AppManager-initialize log' asc = AppManager-    <$> newTVarIO Map.empty-    <*> return asc-    <*> newMVar ()-    <*> return log'+initialize :: KeterM AppStartConfig AppManager+initialize = do+  asc <- ask+  liftIO $ AppManager+      <$> newTVarIO Map.empty+      <*> return asc+      <*> newMVar ()  -- | Reset which apps are running. --@@ -97,16 +103,18 @@ -- * Any app listed here that is currently running will be reloaded. -- -- * Any app listed here that is not currently running will be started.-reloadAppList :: AppManager-              -> Map Appname (FilePath, EpochTime)-              -> IO ()-reloadAppList am@AppManager {..} newApps = withMVar mutex $ const $ do-    actions <- atomically $ do-        m <- readTVar apps-        let currentApps = Set.fromList $ mapMaybe toAppName $ Map.keys m-            allApps = Set.toList $ Map.keysSet newApps `Set.union` currentApps-        fmap catMaybes $ mapM (getAction m) allApps-    sequence_ actions+reloadAppList :: Map Appname (FilePath, EpochTime)+              -> KeterM AppManager ()+reloadAppList newApps = do+  am@AppManager{..} <- ask+  withRunInIO $ \rio -> +    withMVar mutex $ const $ do+      actions <- atomically $ do+          m <- readTVar apps+          let currentApps = Set.fromList $ mapMaybe toAppName $ Map.keys m+              allApps = Set.toList $ Map.keysSet newApps `Set.union` currentApps+          fmap catMaybes $ mapM (getAction m) allApps+      sequence_ $ rio <$> actions   where     toAppName AIBuiltin   = Nothing     toAppName (AINamed x) = Just x@@ -141,8 +149,8 @@             case Map.lookup appname newApps of                 Nothing              -> E.assert False Nothing                 Just (fp, timestamp) -> reload fp timestamp-        terminate = Just $ performNoLock am (AINamed appname) Terminate-        reload fp timestamp = Just $ performNoLock am (AINamed appname) (Reload $ AIBundle fp timestamp)+        terminate = Just $ performNoLock (AINamed appname) Terminate+        reload fp timestamp = Just $ performNoLock (AINamed appname) (Reload $ AIBundle fp timestamp)         {-         case (Map.lookup appname currentApps, Map.lookup appname newApps) of             (Nothing, Nothing) -> E.assert False Nothing@@ -171,37 +179,42 @@     return $ Set.fromList $ mapMaybe toAppName $ Map.keys m     -} -perform :: AppManager -> AppId -> Action -> IO ()-perform am appid action = withMVar (mutex am) $ const $ performNoLock am appid action+perform :: AppId -> Action -> KeterM AppManager ()+perform appid action = do+    am <- ask+    withRunInIO $ \rio -> +      withMVar (mutex am) $ const $ rio $  performNoLock appid action -performNoLock :: AppManager -> AppId -> Action -> IO ()-performNoLock am@AppManager {..} aid action = E.mask_ $ do-    launchWorker' <- atomically $ do-        m <- readTVar apps-        case Map.lookup aid m of-            Just tstate -> do-                state <- readTVar tstate-                case state of-                    ASStarting _mcurrent _tmtimestamp tmnext -> do-                        writeTVar tmnext $ Just action-                        -- use the previous worker, so nothing to do-                        return noWorker-                    ASRunning runningApp -> do-                        tmnext <- newTVar Nothing-                        tmtimestamp <- newTVar $-                            case action of-                                Reload (AIBundle _fp timestamp) -> Just timestamp-                                Reload (AIData _) -> Nothing-                                Terminate -> Nothing-                        writeTVar tstate $ ASStarting (Just runningApp) tmtimestamp tmnext-                        return $ launchWorker am aid tstate tmnext (Just runningApp) action-                    ASTerminated -> onNotRunning-            Nothing -> onNotRunning-    launchWorker'+performNoLock :: AppId -> Action -> KeterM AppManager ()+performNoLock aid action = do+    am@AppManager{..} <- ask+    withRunInIO $ \rio -> E.mask_ $ do+        launchWorker' <- liftIO $ atomically $ do+            m <- readTVar apps+            case Map.lookup aid m of+                Just tstate -> do+                    state <- readTVar tstate+                    case state of+                        ASStarting _mcurrent _tmtimestamp tmnext -> do+                            writeTVar tmnext $ Just action+                            -- use the previous worker, so nothing to do+                            return noWorker+                        ASRunning runningApp -> do+                            tmnext <- newTVar Nothing+                            tmtimestamp <- newTVar $+                                case action of+                                    Reload (AIBundle _fp timestamp) -> Just timestamp+                                    Reload (AIData _) -> Nothing+                                    Terminate -> Nothing+                            writeTVar tstate $ ASStarting (Just runningApp) tmtimestamp tmnext+                            return $ launchWorker aid tstate tmnext (Just runningApp) action+                        ASTerminated -> onNotRunning apps+                Nothing -> onNotRunning apps+        rio launchWorker'   where     noWorker = return () -    onNotRunning =+    onNotRunning apps =         case action of             Reload input -> do                 tmnext <- newTVar Nothing@@ -211,22 +224,22 @@                         AIData _               -> Nothing                 tstate <- newTVar $ ASStarting Nothing tmtimestamp tmnext                 modifyTVar apps $ Map.insert aid tstate-                return $ launchWorker am aid tstate tmnext Nothing action+                return $ launchWorker aid tstate tmnext Nothing action             Terminate -> return noWorker -launchWorker :: AppManager-             -> AppId+launchWorker :: AppId              -> TVar AppState              -> TVar (Maybe Action)              -> Maybe App              -> Action-             -> IO ()-launchWorker AppManager {..} appid tstate tmnext mcurrentApp0 action0 = void $ forkIO $ do-    loop mcurrentApp0 action0+             -> KeterM AppManager ()+launchWorker appid tstate tmnext mcurrentApp0 action0 = +  loop mcurrentApp0 action0   where+    loop :: Maybe App -> Action -> KeterM AppManager ()     loop mcurrentApp action = do         mRunningApp <- processAction mcurrentApp action-        mnext <- atomically $ do+        mnext <- liftIO $ atomically $ do             mnext <- readTVar tmnext             writeTVar tmnext Nothing             case mnext of@@ -246,25 +259,37 @@             Nothing   -> return ()             Just next -> loop mRunningApp next +    reloadMsg :: String -> String -> Text+    reloadMsg app input =+        pack $ "Reloading from: " <> app <> input+    +    errorStartingBundleMsg :: String -> String -> Text+    errorStartingBundleMsg name e = +        pack $ "Error occured when launching bundle " <> name <> ": " <> e++    processAction :: Maybe App -> Action -> KeterM AppManager (Maybe App)     processAction Nothing Terminate = return Nothing     processAction (Just app) Terminate = do-        log $ Terminating $ show app-        App.terminate app+        $logInfo $ pack ("Terminating" <> show app)+        withMappedConfig (const app) App.terminate         return Nothing     processAction Nothing (Reload input) = do-        log $ ReloadFrom Nothing $ show input-        eres <- E.try $ App.start appStartConfig appid input+        $logInfo (reloadMsg "Nothing" (show input))+        AppManager{..} <- ask+        eres <- withRunInIO $ \rio -> E.try @SomeException $ +            rio $ withMappedConfig (const appStartConfig) $ App.start appid input         case eres of             Left e -> do-                log $ ErrorStartingBundle name e+                $logError (errorStartingBundleMsg (show name) (show e))                 return Nothing             Right app -> return $ Just app     processAction (Just app) (Reload input) = do-        log $ ReloadFrom (Just $ show app) (show input)-        eres <- E.try $ App.reload app input+        $logInfo (reloadMsg (show $ Just app) (show input))+        eres <- withRunInIO $ \rio -> E.try @SomeException $ +            rio $ withMappedConfig (const app) $ App.reload input         case eres of             Left e -> do-                log $ ErrorStartingBundle name e+                $logError (errorStartingBundleMsg (show name) (show e))                 -- reloading will /always/ result in a valid app, either the old one                 -- will continue running or the new one will replace it.                 return (Just app)@@ -275,16 +300,15 @@             AIBuiltin -> "<builtin>"             AINamed x -> x -addApp :: AppManager -> FilePath -> IO ()-addApp appMan bundle = do-    (input, action) <- getInputForBundle bundle-    perform appMan input action+addApp :: FilePath -> KeterM AppManager ()+addApp bundle = do+    (input, action) <- liftIO $ getInputForBundle bundle+    perform input action  getInputForBundle :: FilePath -> IO (AppId, Action) getInputForBundle bundle = do     time <- modificationTime <$> getFileStatus bundle     return (AINamed $ getAppname bundle, Reload $ AIBundle bundle time) -terminateApp :: AppManager -> Appname -> IO ()-terminateApp appMan appname = perform appMan (AINamed appname) Terminate-+terminateApp :: Appname -> KeterM AppManager ()+terminateApp appname = perform (AINamed appname) Terminate

@@ -1,14 +1,22 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-} module Keter.Cli     ( launchCli     , CliStates(..)     ) where  import Keter.Common+import Keter.Context import Keter.AppManager import Control.Concurrent (forkFinally) import qualified Control.Exception as E import Control.Monad (unless, forever, void, when)+import Control.Monad.IO.Class    (MonadIO, liftIO)+import Control.Monad.IO.Unlift   (withRunInIO)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Logger+import Control.Monad.Reader      (ask) import qualified Data.ByteString as S import Network.Socket import Network.Socket.ByteString (recv, sendAll)@@ -23,16 +31,19 @@  data CliStates = MkCliStates   { csAppManager :: !AppManager-  , csLog        :: !(LogMessage -> IO ())   , csPort       :: !Port   } -launchCli :: CliStates -> IO ()-launchCli states = void $ forkIO $ withSocketsDo $ do-    addr <- resolve $ show $ csPort states-    E.bracket (open addr) close $ \x -> do-                                    csLog states $ BindCli addr-                                    loop states x+launchCli :: KeterM CliStates ()+launchCli = do+  MkCliStates{..} <- ask+  void $ withRunInIO $ \rio -> forkIO $ +    withSocketsDo $ do+        addr <- resolve $ show csPort+        E.bracket (open addr) close $ \x -> rio $ do+            $logInfo $ T.pack $ "Bound cli to " <> show addr+            loop x+ commandParser :: Parser Commands commandParser = hsubparser $   fold [@@ -65,31 +76,33 @@     listen sock 10     return sock -loop :: CliStates -> Socket -> IO b-loop states sock = forever $ do-    (conn, peer) <- accept sock-    csLog states $ ReceivedCliConnection peer-    void $ forkFinally (talk states conn) (\_ -> close conn)+loop :: Socket -> KeterM CliStates b+loop sock = forever $ do+    (conn, peer) <- liftIO $ accept sock+    $logInfo $ T.pack $ "CLI Connection from " <> show peer+    void $ withRunInIO $ \rio -> +        forkFinally (rio $ talk conn) (\_ -> close conn) -listRunningApps :: CliStates -> Socket -> IO ()-listRunningApps states conn = do-  txt <- atomically $ renderApps $ csAppManager states-  sendAll conn $ T.encodeUtf8 txt <> "\n"+listRunningApps :: Socket -> KeterM CliStates ()+listRunningApps conn = do+  MkCliStates{..} <- ask+  txt <- liftIO $ atomically $ renderApps csAppManager +  liftIO $ sendAll conn $ T.encodeUtf8 txt <> "\n" -talk :: CliStates -> Socket -> IO ()-talk states conn = do-    msg <- recv conn 1024+talk :: Socket -> KeterM CliStates ()+talk conn = do+    msg <- liftIO $ recv conn 1024     unless (S.null msg) $ do       case T.decodeUtf8' msg of-        Left exception -> sendAll conn ("decode error: " <> T.encodeUtf8 (T.pack $ show exception))+        Left exception -> liftIO $ sendAll conn ("decode error: " <> T.encodeUtf8 (T.pack $ show exception))         Right txt -> do           let res = execParserPure defaultPrefs (info (commandParser <**> helper)                                                 (fullDesc <> header "server repl" <> progDesc (                         "repl for inspecting program state. You can connect to a socket and ask predefined questions")) ) (T.unpack <$> T.words txt)           isLoop <- case res of-            (Success (CmdListRunningApps)) -> True <$ listRunningApps states conn-            (Success (CmdExit   )) -> False <$ sendAll conn "bye\n"-            (CompletionInvoked x) -> True <$ sendAll conn "completion ignored \n"+            (Success (CmdListRunningApps)) -> True <$ listRunningApps conn+            (Success (CmdExit   )) -> False <$ liftIO (sendAll conn "bye\n")+            (CompletionInvoked x) -> True <$ liftIO (sendAll conn "completion ignored \n")             Failure failure        ->-              True <$ sendAll conn (T.encodeUtf8 (T.pack $ fst $ renderFailure failure "") <> "\n")-          when isLoop $ talk states conn+              True <$ liftIO (sendAll conn (T.encodeUtf8 (T.pack $ fst $ renderFailure failure "") <> "\n"))+          when isLoop $ talk conn

@@ -56,107 +56,6 @@ getAppname :: FilePath -> Text getAppname = pack . takeBaseName -data LogMessage-    = ProcessCreated FilePath-    | InvalidBundle FilePath SomeException-    | ProcessDidNotStart FilePath-    | ExceptionThrown Text SomeException-    | RemovingPort Int-    | UnpackingBundle FilePath-    | TerminatingApp Text-    | FinishedReloading Text-    | TerminatingOldProcess AppId-    | RemovingOldFolder FilePath-    | ReceivedInotifyEvent Text-    | ProcessWaiting FilePath-    | OtherMessage Text-    | ErrorStartingBundle Text SomeException-    | SanityChecksPassed-    | ReservingHosts AppId (Set Host)-    | ForgetingReservations AppId (Set Host)-    | ActivatingApp AppId (Set Host)-    | DeactivatingApp AppId (Set Host)-    | ReactivatingApp AppId (Set Host) (Set Host)-    | WatchedFile Text FilePath-    | ReloadFrom (Maybe String) String-    | Terminating String-    | LaunchInitial-    | LaunchCli-    | StartWatching-    | StartListening-    | BindCli AddrInfo-    | ReceivedCliConnection SockAddr-    | KillingApp Port Text-    | ProxyException Wai.Request SomeException--instance Show LogMessage where-    show (ProcessCreated f) = "Created process: " ++ f-    show (ReloadFrom app input) = "Reloading from: " ++ show app  ++ " to " ++ show input-    show (Terminating app) = "Terminating " ++ show app-    show (InvalidBundle f e) = concat-        [ "Unable to parse bundle file '"-        , f-        , "': "-        , show e-        ]-    show (ProcessDidNotStart fp) = concat-        [ "Could not start process within timeout period: "-        , fp-        ]-    show (ExceptionThrown t e) = concat-        [ unpack t-        , ": "-        , show e-        ]-    show (RemovingPort p) = "Port in use, removing from port pool: " ++ show p-    show (UnpackingBundle b) = concat-        [ "Unpacking bundle '"-        , b-        , "'"-        ]-    show (TerminatingApp t) = "Shutting down app: " ++ unpack t-    show (FinishedReloading t) = "App finished reloading: " ++ unpack t-    show (TerminatingOldProcess (AINamed t)) = "Sending old process TERM signal: " ++ unpack t-    show (TerminatingOldProcess AIBuiltin) = "Sending old process TERM signal: builtin"-    show (RemovingOldFolder fp) = "Removing unneeded folder: " ++ fp-    show (ReceivedInotifyEvent t) = "Received unknown INotify event: " ++ unpack t-    show (ProcessWaiting f) = "Process restarting too quickly, waiting before trying again: " ++ f-    show (OtherMessage t) = unpack t-    show (ErrorStartingBundle name e) = concat-        [ "Error occured when launching bundle "-        , unpack name-        , ": "-        , show e-        ]-    show SanityChecksPassed = "Sanity checks passed"-    show (ReservingHosts app hosts) = "Reserving hosts for app " ++ show app ++ ": " ++ unwords (map (unpack . original) $ Set.toList hosts)-    show (ForgetingReservations app hosts) = "Forgetting host reservations for app " ++ show app ++ ": " ++ unwords (map (unpack . original) $ Set.toList hosts)-    show (ActivatingApp app hosts) = "Activating app " ++ show app ++ " with hosts: " ++ unwords (map (unpack . original) $ Set.toList hosts)-    show (DeactivatingApp app hosts) = "Deactivating app " ++ show app ++ " with hosts: " ++ unwords (map (unpack . original) $ Set.toList hosts)-    show (ReactivatingApp app old new) = concat-        [ "Reactivating app "-        , show app-        , ".  Old hosts: "-        , unwords (map (unpack . original) $ Set.toList old)-        , ". New hosts: "-        , unwords (map (unpack . original) $ Set.toList new)-        , "."-        ]-    show (WatchedFile action fp) = concat-        [ "Watched file "-        , unpack action-        , ": "-        , fp-        ]-    show LaunchInitial = "Launching initial"-    show (KillingApp port txt) = "Killing " <> unpack txt <> " running on port: "  <> show port-    show LaunchCli     = "Launching cli"-    show StartWatching = "Started watching"-    show StartListening = "Started listening"-    show (BindCli addr) = "Bound cli to " <> show addr-    show (ReceivedCliConnection peer) = "CLI Connection from " <> show peer-    show (ProxyException req except) = "Got a proxy exception on request " <> show req <> " with exception "  <> show except- data KeterException = CannotParsePostgres FilePath                     | ExitCodeFailure FilePath ExitCode                     | NoPortsAvailable@@ -168,18 +67,6 @@                     | EnsureAliveShouldBeBiggerThenZero { keterExceptionGot:: !Int }     deriving (Show, Typeable) instance Exception KeterException--logEx :: TH.Q TH.Exp-logEx = do-    let showLoc TH.Loc { TH.loc_module = m, TH.loc_start = (l, c) } = concat-            [ m-            , ":"-            , show l-            , ":"-            , show c-            ]-    loc <- fmap showLoc TH.qLocation-    [|(. ExceptionThrown (pack $(TH.lift loc)))|]  data AppId = AIBuiltin | AINamed !Appname     deriving (Eq, Ord)

@@ -1,140 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Keter.Conduit.LogFile-    ( RotatingLog-    , openRotatingLog-    , addChunk-    , close-    , defaultMaxTotal-    , dummy-    ) where--import           Control.Concurrent             (forkIO)-import           Control.Concurrent.STM         (atomically)-import           Control.Concurrent.STM.TBQueue-import           Control.Concurrent.STM.TVar-import           Control.Exception              (bracket, bracketOnError,-                                                 finally)-import           Control.Monad                  (void, when)-import qualified Data.ByteString                as S-import           Data.Time                      (UTCTime, getCurrentTime)-import           Data.Word                      (Word)-import           System.Directory               (createDirectoryIfMissing,-                                                 doesFileExist, renameFile)-import           System.FilePath                ((<.>), (</>))-import qualified System.IO                      as SIO-import           System.IO.Unsafe               (unsafePerformIO)-import           System.Mem.Weak                (addFinalizer)--data Command = AddChunk !S.ByteString-             | Close---- | Represents a folder used for totating log files.------ Since 0.2.1-data RotatingLog = RotatingLog !(TVar State)--- Use a data instead of a newtype so that we can attach a finalizer.---- | A @RotatingLog@ which performs no logging.------ Since 0.2.1-dummy :: RotatingLog-dummy = RotatingLog $! unsafePerformIO $! newTVarIO Closed--data State = Closed-           | Running !SIO.Handle !(TBQueue Command)--queue :: Command -> RotatingLog -> IO ()-queue cmd (RotatingLog ts) = atomically $ do-    s <- readTVar ts-    case s of-        Closed -> return ()-        Running _ q -> writeTBQueue q cmd--addChunk :: RotatingLog -> S.ByteString -> IO ()-addChunk lf bs = queue (AddChunk bs) lf--close :: RotatingLog -> IO ()-close = queue Close---- | Create a new @RotatingLog@.------ Since 0.2.1-openRotatingLog :: FilePath -- ^ folder to contain logs-                -> Word -- ^ maximum log file size, in bytes-                -> IO RotatingLog-openRotatingLog dir maxTotal = do-    createDirectoryIfMissing True dir-    bracketOnError (moveCurrent dir) SIO.hClose $ \handle -> do-        queue' <- newTBQueueIO 5-        let s = Running handle queue'-        ts <- newTVarIO s-        void $ forkIO $ loop dir ts maxTotal-        let rl = RotatingLog ts-        addFinalizer rl (atomically (writeTBQueue queue' Close))-        return rl--current :: FilePath -- ^ folder containing logs-        -> FilePath-current = (</> "current.log")--moveCurrent :: FilePath -- ^ folder containing logs-            -> IO SIO.Handle -- ^ new handle-moveCurrent dir = do-    let curr = current dir-    x <- doesFileExist curr-    when x $ do-        now <- getCurrentTime-        renameFile curr $ dir </> suffix now-    SIO.openFile curr SIO.WriteMode--suffix :: UTCTime -> FilePath-suffix now =-    (concatMap fix $ takeWhile (/= '.') $ show now) <.> "log"-  where-    fix ' ' = "_"-    fix c | '0' <= c && c <= '9' = [c]-    fix _ = ""--loop :: FilePath -- ^ folder containing logs-     -> TVar State-     -> Word -- ^ maximum total log size-     -> IO ()-loop dir ts maxTotal =-    go 0 `finally` (closeCurrentHandle `finally` atomically (writeTVar ts Closed))-  where-    closeCurrentHandle = bracket-        (atomically $ do-            s <- readTVar ts-            case s of-                Closed -> return Nothing-                Running h _ -> return $! Just h)-        (maybe (return ()) SIO.hClose)-        (const $ return ())--    go total = do-        res <- atomically $ do-            s <- readTVar ts-            case s of-                Closed -> return Nothing-                Running handle queue' -> do-                    cmd <- readTBQueue queue'-                    case cmd of-                        Close -> return Nothing-                        AddChunk bs -> return $! Just (handle, queue', bs)-        case res of-            Nothing -> return ()-            Just (handle, queue', bs) -> do-                let total' = total + fromIntegral (S.length bs)-                S.hPut handle bs-                SIO.hFlush handle-                if total' > maxTotal-                    then do-                        bracket-                            (SIO.hClose handle >> moveCurrent dir)-                            (\handle' -> atomically $ writeTVar ts $ Running handle' queue')-                            (const $ return ())-                        go 0-                    else go total'--defaultMaxTotal :: Word-defaultMaxTotal = 5 * 1024 * 1024 -- 5 MB

@@ -3,6 +3,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings        #-} {-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE TemplateHaskell          #-}  module Keter.Conduit.Process.Unix     ( -- * Process tracking@@ -21,6 +22,7 @@     ) where  import           Data.Text(Text, pack)+import           Data.Text.Encoding              (decodeUtf8) import           Control.Applicative             ((<$>), (<*>), pure) import           Control.Arrow                   ((***)) import           Control.Concurrent              (forkIO)@@ -34,6 +36,9 @@                                                   handle, mask_,                                                   throwIO, try) import           Control.Monad                   (void)+import           Control.Monad.IO.Class+import           Control.Monad.IO.Unlift+import           Control.Monad.Logger             import           Data.ByteString                 (ByteString) import qualified Data.ByteString.Char8           as S8 import           Data.Conduit                    (ConduitM, (.|), runConduit)@@ -199,7 +204,7 @@                -> Maybe (ConduitM () ByteString IO ()) -- ^ stdin                -> (ByteString -> IO ()) -- ^ both stdout and stderr will be sent to this location                -> IO ProcessHandle-forkExecuteLog cmd args menv mwdir mstdin rlog = bracketOnError+forkExecuteLog cmd args menv mwdir mstdin log = bracketOnError     setupPipe     cleanupPipes     usePipes@@ -238,7 +243,7 @@             }         ignoreExceptions $ addAttachMessage pipes ph         void $ forkIO $ ignoreExceptions $-            (runConduit $ sourceHandle readerH .| CL.mapM_ rlog) `finally` hClose readerH+            (runConduit $ sourceHandle readerH .| CL.mapM_ log) `finally` hClose readerH         case (min, mstdin) of             (Just h, Just source) -> void $ forkIO $ ignoreExceptions $                 (runConduit $ source .| sinkHandle h) `finally` hClose h@@ -250,7 +255,7 @@         now <- getCurrentTime         case p_ of             ClosedHandle ec -> do-                rlog $ S8.concat+                log $ S8.concat                     [ "\n\n"                     , S8.pack $ show now                     , ": Process immediately died with exit code "@@ -259,7 +264,7 @@                     ]                 cleanupPipes pipes             OpenHandle h -> do-                rlog $ S8.concat+                log $ S8.concat                     [ "\n\n"                     , S8.pack $ show now                     , ": Attached new process "@@ -272,8 +277,8 @@  -- | Run the given command, restarting if the process dies. monitorProcess-    :: (ByteString -> IO ()) -- ^ log-    -> ProcessTracker+    :: (MonadUnliftIO m, MonadLogger m)+    => ProcessTracker     -> Maybe S8.ByteString -- ^ setuid     -> S8.ByteString -- ^ executable     -> S8.ByteString -- ^ working directory@@ -281,47 +286,48 @@     -> [(S8.ByteString, S8.ByteString)] -- ^ environment     -> (ByteString -> IO ())     -> (ExitCode -> IO Bool) -- ^ should we restart?-    -> IO MonitoredProcess-monitorProcess log processTracker msetuid exec dir args env' rlog shouldRestart = do-    mstatus <- newMVar NeedsRestart-    let loop mlast = do-            next <- modifyMVar mstatus $ \status ->-                case status of-                    NoRestart -> return (NoRestart, return ())-                    _ -> do-                        now <- getCurrentTime-                        case mlast of-                            Just last | diffUTCTime now last < 5 -> do-                                log $ "Process restarting too quickly, waiting before trying again: " `S8.append` exec-                                threadDelay $ 5 * 1000 * 1000-                            _ -> return ()-                        let (cmd, args') =-                                case msetuid of-                                    Nothing -> (exec, args)-                                    Just setuid -> ("sudo", "-E" : "-u" : setuid : "--" : exec : args)-                        res <- try $ forkExecuteLog-                            cmd-                            args'-                            (Just env')-                            (Just dir)-                            (Just $ return ())-                            rlog-                        case res of-                            Left e -> do-                                log $ "Data.Conduit.Process.Unix.monitorProcess: " `S8.append` S8.pack (show (e :: SomeException))-                                return (NeedsRestart, return ())-                            Right pid -> do-                                log $ "Process created: " `S8.append` exec-                                return (Running pid, do-                                    TrackedProcess _ _ wait <- trackProcess processTracker pid-                                    ec <- wait-                                    shouldRestart' <- shouldRestart ec-                                    if shouldRestart'-                                        then loop (Just now)-                                        else return ())-            next-    _ <- forkIO $ loop Nothing-    return $ MonitoredProcess mstatus+    -> m MonitoredProcess+monitorProcess processTracker msetuid exec dir args env' rlog shouldRestart =+    withRunInIO $ \rio -> do+        mstatus <- newMVar NeedsRestart+        let loop mlast = do+                next <- modifyMVar mstatus $ \status ->+                    case status of+                        NoRestart -> return (NoRestart, return ())+                        _ -> do+                            now <- getCurrentTime+                            case mlast of+                                Just last | diffUTCTime now last < 5 -> do+                                    rio $ $logWarn $ "Process restarting too quickly, waiting before trying again: " <> decodeUtf8 exec+                                    threadDelay $ 5 * 1000 * 1000+                                _ -> return ()+                            let (cmd, args') =+                                    case msetuid of+                                        Nothing -> (exec, args)+                                        Just setuid -> ("sudo", "-E" : "-u" : setuid : "--" : exec : args)+                            res <- try $ forkExecuteLog+                                cmd+                                args'+                                (Just env')+                                (Just dir)+                                (Just $ return ())+                                rlog+                            case res of+                                Left e -> do+                                    rio $ $logError $ "Data.Conduit.Process.Unix.monitorProcess: " <> pack (show (e :: SomeException))+                                    return (NeedsRestart, return ())+                                Right pid -> do+                                    rio $ $logInfo $ "Process created: " <> decodeUtf8 exec+                                    return (Running pid, do+                                        TrackedProcess _ _ wait <- trackProcess processTracker pid+                                        ec <- wait+                                        shouldRestart' <- shouldRestart ec+                                        if shouldRestart'+                                            then loop (Just now)+                                            else return ())+                next+        _ <- forkIO $ loop Nothing+        return $ MonitoredProcess mstatus  -- | Abstract type containing information on a process which will be restarted. newtype MonitoredProcess = MonitoredProcess (MVar Status)

@@ -112,6 +112,7 @@     , kconfigUnknownHostResponse  :: !(Maybe F.FilePath)     , kconfigMissingHostResponse  :: !(Maybe F.FilePath)     , kconfigProxyException       :: !(Maybe F.FilePath)+    , kconfigRotateLogs           :: !Bool     }  instance ToCurrent KeterConfig where@@ -131,6 +132,7 @@         , kconfigUnknownHostResponse  = Nothing         , kconfigMissingHostResponse = Nothing         , kconfigProxyException      = Nothing+        , kconfigRotateLogs = True         }       where         getSSL Nothing = V.empty@@ -154,10 +156,11 @@         , kconfigExternalHttpsPort = 443         , kconfigEnvironment = Map.empty         , kconfigConnectionTimeBound = V04.fiveMinutes-        , kconfigCliPort             = Nothing-        , kconfigUnknownHostResponse  = Nothing+        , kconfigCliPort = Nothing+        , kconfigUnknownHostResponse = Nothing         , kconfigMissingHostResponse = Nothing-        , kconfigProxyException      = Nothing+        , kconfigProxyException = Nothing+        , kconfigRotateLogs = True         }  instance ParseYamlFile KeterConfig where@@ -182,6 +185,7 @@             <*> o .:? "missing-host-response-file"             <*> o .:? "unknown-host-response-file"             <*> o .:? "proxy-exception-response-file"+            <*> o .:? "rotate-logs" .!= True  -- | Whether we should force redirect to HTTPS routes. type RequiresSecure = Bool

@@ -0,0 +1,28 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies         #-}++module Keter.Context where++import           Keter.Common+import           Control.Monad.Trans       (lift)+import           Control.Monad.IO.Class   (MonadIO)+import           Control.Monad.IO.Unlift   (MonadUnliftIO)+import           Control.Monad.Logger      (MonadLogger, MonadLoggerIO, LoggingT(..), runLoggingT)+import           Control.Monad.Reader      (MonadReader, ReaderT, runReaderT, ask+                                           , withReaderT)++-- | The top-level keter context monad, carrying around the main logger and some locally relevant configuration structure.+--+-- See this blog post for an explanation of the design philosophy: https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/+--+-- TODO: generalize as /contexts/ instead of /configs/? Since not every state being passed+-- around can be intuitively thought of as a config per se. Ex. AppManager+newtype KeterM cfg a = KeterM { runKeterM :: LoggingT (ReaderT cfg IO) a }+  deriving newtype (Functor, Applicative, Monad,+                    MonadUnliftIO,+                    MonadIO, MonadLogger, MonadLoggerIO,+                    MonadReader cfg)++withMappedConfig :: (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a+withMappedConfig f (KeterM ctx) = +    KeterM $ LoggingT $ \logger -> withReaderT f $ runLoggingT ctx logger

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE TemplateHaskell     #-} module Keter.HostManager     ( -- * Types       HostManager@@ -16,11 +17,16 @@     , start     ) where +import Keter.Context import           Control.Applicative import           Control.Exception   (assert, throwIO)+import           Control.Monad.Logger+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Reader    (ask) import qualified Data.CaseInsensitive as CI import           Data.Either         (partitionEithers) import           Data.IORef+import           Data.Text           (pack, unpack) import qualified Data.Map            as Map import qualified Data.Set            as Set import           Data.Text.Encoding  (encodeUtf8)@@ -59,18 +65,22 @@ -- -- 4. Otherwise, the hosts which were reserved are returned as @Right@. This --    does /not/ include previously active hosts.-reserveHosts :: (LogMessage -> IO ())-             -> HostManager-             -> AppId+reserveHosts :: AppId              -> Set.Set Host-             -> IO Reservations-reserveHosts log (HostManager mstate) aid hosts = do-  log $ ReservingHosts aid hosts-  either (throwIO . CannotReserveHosts aid) return =<< atomicModifyIORef mstate (\entries0 ->-    case partitionEithers $ map (checkHost entries0) $ Set.toList hosts of-        ([], Set.unions -> toReserve) ->-            (Set.foldr reserve entries0 toReserve, Right toReserve)-        (conflicts, _) -> (entries0, Left $ Map.fromList conflicts))+             -> KeterM HostManager Reservations+reserveHosts aid hosts = do+  (HostManager mstate) <- ask+  $logInfo $ pack $ +      "Reserving hosts for app " +      ++ show aid+      ++ ": " +      ++ unwords (map (unpack . CI.original) $ Set.toList hosts)+  liftIO $ either (throwIO . CannotReserveHosts aid) return +    =<< atomicModifyIORef mstate (\entries0 ->+      case partitionEithers $ map (checkHost entries0) $ Set.toList hosts of+          ([], Set.unions -> toReserve) ->+              (Set.foldr reserve entries0 toReserve, Right toReserve)+          (conflicts, _) -> (entries0, Left $ Map.fromList conflicts))   where     checkHost entries0 host =         case LabelMap.labelAssigned hostBS entries0 of@@ -92,14 +102,17 @@         hostBS = encodeUtf8 $ CI.original host  -- | Forget previously made reservations.-forgetReservations :: (LogMessage -> IO ())-                   -> HostManager-                   -> AppId+forgetReservations :: AppId                    -> Reservations-                   -> IO ()-forgetReservations log (HostManager mstate) app hosts = do-    log $ ForgetingReservations app hosts-    atomicModifyIORef mstate $ \state0 ->+                   -> KeterM HostManager ()+forgetReservations app hosts = do+    (HostManager mstate) <- ask+    $logInfo $ pack $ +        "Forgetting host reservations for app " +        ++ show app +        ++ ": " +        ++ unwords (map (unpack . CI.original) $ Set.toList hosts)+    liftIO $ atomicModifyIORef mstate $ \state0 ->         (Set.foldr forget state0 hosts, ())   where     forget host state =@@ -113,14 +126,18 @@                 Just HVActive{} -> False  -- | Activate a new app. Note that you /must/ first reserve the hostnames you'll be using.-activateApp :: (LogMessage -> IO ())-            -> HostManager-            -> AppId+activateApp :: AppId             -> Map.Map Host (ProxyAction, TLS.Credentials)-            -> IO ()-activateApp log (HostManager mstate) app actions = do-    log $ ActivatingApp app $ Map.keysSet actions-    atomicModifyIORef mstate $ \state0 ->+            -> KeterM HostManager ()+activateApp app actions = do+    (HostManager mstate) <- ask+    $logInfo $ pack $ concat+        [ "Activating app "+        , show app+        , " with hosts: "+        , unwords (map (unpack . CI.original) $ Set.toList (Map.keysSet actions))+        ]+    liftIO $ atomicModifyIORef mstate $ \state0 ->         (activateHelper app state0 actions, ())  activateHelper :: AppId -> LabelMap HostValue -> Map Host (ProxyAction, TLS.Credentials) -> LabelMap HostValue@@ -137,14 +154,13 @@                 Just (HVReserved app') -> app == app'                 Just (HVActive app' _ _) -> app == app' -deactivateApp :: (LogMessage -> IO ())-              -> HostManager-              -> AppId+deactivateApp :: AppId               -> Set Host-              -> IO ()-deactivateApp log (HostManager mstate) app hosts = do-    log $ DeactivatingApp app hosts-    atomicModifyIORef mstate $ \state0 ->+              -> KeterM HostManager ()+deactivateApp app hosts = do+    $logInfo $ pack $ "Deactivating app " ++ show app ++ " with hosts: " ++ unwords (map (unpack . CI.original) $ Set.toList hosts)+    (HostManager mstate) <- ask+    liftIO $ atomicModifyIORef mstate $ \state0 ->         (deactivateHelper app state0 hosts, ())  deactivateHelper :: AppId -> LabelMap HostValue -> Set Host -> LabelMap HostValue@@ -161,15 +177,22 @@                 Just (HVActive app' _ _) -> app == app'                 Just HVReserved {} -> False -reactivateApp :: (LogMessage -> IO ())-              -> HostManager-              -> AppId+reactivateApp :: AppId               -> Map Host (ProxyAction, TLS.Credentials)               -> Set Host-              -> IO ()-reactivateApp log (HostManager mstate) app actions hosts = do-    log $ ReactivatingApp app hosts (Map.keysSet actions)-    atomicModifyIORef mstate $ \state0 ->+              -> KeterM HostManager ()+reactivateApp app actions hosts = do+    (HostManager mstate) <- ask+    $logInfo $ pack $ concat+        [ "Reactivating app "+        , show app+        , ".  Old hosts: "+        , unwords (map (unpack . CI.original) $ Set.toList hosts)+        , ". New hosts: "+        , unwords (map (unpack . CI.original) $ Set.toList (Map.keysSet actions))+        , "."+        ]+    liftIO $ atomicModifyIORef mstate $ \state0 ->         (activateHelper app (deactivateHelper app state0 hosts) actions, ())  lookupAction :: HostManager

@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+module Keter.Logger+    ( Logger(..)+    , createLoggerViaConfig+    , defaultRotationSpec+    , defaultMaxTotal+    , defaultBufferSize+    ) where++import Data.Time+import Debug.Trace+import qualified System.Log.FastLogger as FL+import System.Directory+import System.FilePath+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Keter.Context+import Keter.Config.V10++-- | Record wrapper over a fast logger (log,close) function tuple, just to make it less unwieldy and obscure.+-- The 'LogType' is also tracked, in case formatting depends on it.+data Logger = Logger+  { loggerLog :: forall a. FL.ToLogStr a => a -> IO ()+  , loggerClose :: IO () +  , loggerType :: FL.LogType+  }++-- | Create a logger based on a 'KeterConfig'.+-- If log rotation is enabled in the config, this will return a rotating file logger;+-- and a stderr logger otherwise.+createLoggerViaConfig :: KeterConfig+                      -> String -- ^ Log file name+                      -> IO Logger+createLoggerViaConfig KeterConfig{..} name = do+  let logFile = kconfigDir </> "log" </> name <.> "log"+  let logType =+       if kconfigRotateLogs+         then FL.LogFile (defaultRotationSpec logFile) defaultBufferSize+         else FL.LogStderr defaultBufferSize+  liftIO $ createDirectoryIfMissing True (takeDirectory logFile)+  mkLogger logType <$> FL.newFastLogger logType+  where+    mkLogger logType (logFn, closeFn) = Logger (logFn . FL.toLogStr) closeFn logType++defaultRotationSpec :: FilePath -> FL.FileLogSpec+defaultRotationSpec dir =+    FL.FileLogSpec dir defaultMaxTotal maxBound -- TODO: do we want to overwrite logs after a certain point? leaving this INT_MAX for now++-- | The default total file size before for a log file before it needs to be rotated+defaultMaxTotal :: Integer+defaultMaxTotal = 5 * 1024 * 1024 -- 5 MB++-- | The default log message buffer size+defaultBufferSize :: Int+defaultBufferSize = 256 -- 256 bytes, TODO: Reasonable value?

@@ -1,9 +1,12 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE TypeFamilies               #-}  module Keter.Main     ( keter@@ -14,7 +17,7 @@ import qualified Keter.TempTarball as TempFolder import           Control.Concurrent.Async  (waitAny, withAsync) import           Control.Monad             (unless)-import qualified Keter.Conduit.LogFile      as LogFile+import qualified Keter.Logger              as Log import           Data.Monoid               (mempty) import           Data.String               (fromString) import qualified Data.Vector               as V@@ -30,9 +33,15 @@                                             sigHUP)  import           Control.Applicative       ((<$>))-import           Control.Exception         (throwIO, try, SomeException)-import           Control.Monad             (forM)-import           Control.Monad             (void, when)+import           Control.Exception         (throwIO, try, bracket, SomeException)+import           Control.Monad             (forM, void, when)+import           Control.Monad.IO.Class    (MonadIO, liftIO)+import           Control.Monad.Trans.Class (MonadTrans, lift)+import qualified Control.Monad.Logger      as L+import           Control.Monad.Logger      (MonadLogger, MonadLoggerIO, LoggingT, +                                            runLoggingT, askLoggerIO, logInfo, logDebug)+import           Control.Monad.Reader      (MonadReader, ReaderT, runReaderT, ask)+import           Control.Monad.IO.Unlift   (MonadUnliftIO, withRunInIO) import           Keter.Conduit.Process.Unix (initProcessTracker) import qualified Data.Map                  as Map import qualified Data.Text                 as T@@ -45,8 +54,9 @@                                             createDirectoryIfMissing,                                             doesDirectoryExist, doesFileExist,                                             getDirectoryContents)-import           System.FilePath           (takeExtension, (</>))+import           System.FilePath           (takeExtension, takeDirectory, (</>)) import qualified System.FSNotify           as FSN+import qualified System.Log.FastLogger     as FL import           System.Posix.User         (getUserEntryForID,                                             getUserEntryForName, userGroupID,                                             userID, userName)@@ -55,32 +65,38 @@ import           Filesystem.Path.CurrentOS (encodeString) #endif import Keter.Cli+import Keter.Context  keter :: FilePath -- ^ root directory or config file       -> [FilePath -> IO Plugin]       -> IO ()-keter input mkPlugins = withManagers input mkPlugins $ \kc hostman appMan log -> do-    log LaunchCli-    void $ forM (kconfigCliPort kc) $ \port ->-      launchCli (MkCliStates-                { csAppManager = appMan-                , csLog        = log-                , csPort       = port-                })-    log LaunchInitial-    launchInitial kc appMan-    log StartWatching-    startWatching kc appMan log-    log StartListening-    startListening log kc hostman+keter input mkPlugins =+    runKeterConfigReader input . runKeterLogger . runKeterM $+        withManagers mkPlugins $ \hostman appMan -> do+            cfg@KeterConfig{..} <- ask+            $logInfo "Launching cli"+            void $ forM kconfigCliPort $ \port ->+              withMappedConfig+                  (const $ MkCliStates+                      { csAppManager = appMan+                      , csPort       = port+                      })+                  $ launchCli+            $logInfo "Launching initial"+            launchInitial appMan+            $logInfo "Started watching"+            startWatching appMan+            $logInfo "Started listening"+            startListening hostman --- | Load up Keter config.-withConfig :: FilePath-           -> (KeterConfig -> IO a)-           -> IO a-withConfig input f = do-    exists <- doesFileExist input-    config <-+-- | Load up Keter config and evaluate a ReaderT context with it+runKeterConfigReader :: MonadIO m+                     => FilePath+                     -> ReaderT KeterConfig m a+                     -> m a+runKeterConfigReader input ctx = do+    exists <- liftIO $ doesFileExist input+    config <- liftIO $         if exists             then do                 eres <- decodeFileRelative input@@ -88,41 +104,53 @@                     Left e -> throwIO $ InvalidKeterConfigFile input e                     Right x -> return x             else return defaultKeterConfig { kconfigDir = input }-    f config--withLogger :: FilePath-           -> (KeterConfig -> (LogMessage -> IO ()) -> IO a)-           -> IO a-withLogger fp f = withConfig fp $ \config -> do-    mainlog <- LogFile.openRotatingLog-        (kconfigDir config </> "log" </> "keter")-        LogFile.defaultMaxTotal+    runReaderT ctx config -    f config $ \ml -> do-        now <- getCurrentTime-        let bs = encodeUtf8 $ T.pack $ concat-                [ take 22 $ show now-                , ": "-                , show ml-                , "\n"-                ]-        LogFile.addChunk mainlog bs+-- | Running the Keter logger requires a context with access to a KeterConfig, hence the+-- MonadReader constraint. This is versatile: 'runKeterConfigReader', or use the free +-- ((->) KeterConfig) instance.+runKeterLogger :: (MonadReader KeterConfig m, MonadIO m, MonadUnliftIO m)+               => LoggingT m a+               -> m a+runKeterLogger ctx = do+    cfg@KeterConfig{..} <- ask+    withRunInIO $ \rio -> bracket (Log.createLoggerViaConfig cfg "keter") Log.loggerClose $+        rio . runLoggingT ctx . formatLog +    where+        formatLog logger loc _ lvl msg = do+            now <- liftIO getCurrentTime+            -- Format: "{keter|}$time|$module$:$line_num|$log_level> $msg"+            let tag = case Log.loggerType logger of { FL.LogStderr _ -> "keter|"; _ -> mempty }+            let bs = mconcat+                    [ tag+                    , L.toLogStr $ take 22 $ show now+                    , "|"+                    , L.toLogStr (L.loc_module loc)+                    , ":"+                    , L.toLogStr (fst $ L.loc_start loc)+                    , "|"+                    , L.toLogStr $ drop 5 $ show lvl+                    , "> "+                    , msg+                    , "\n"+                    ]+            Log.loggerLog logger bs -withManagers :: FilePath-             -> [FilePath -> IO Plugin]-             -> (KeterConfig -> HostMan.HostManager -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO a)-             -> IO a-withManagers input mkPlugins f = withLogger input $ \kc@KeterConfig {..} log -> do-    processTracker <- initProcessTracker-    hostman <- HostMan.start-    portpool <- PortPool.start kconfigPortPool-    tf <- TempFolder.setup $ kconfigDir </> "temp"-    plugins <- mapM ($ kconfigDir) mkPlugins+withManagers :: [FilePath -> IO Plugin]+             -> (HostMan.HostManager -> AppMan.AppManager -> KeterM KeterConfig a)+             -> KeterM KeterConfig a+withManagers mkPlugins f = do+    cfg@KeterConfig{..} <- ask+    processTracker <- liftIO initProcessTracker+    hostman <- liftIO HostMan.start+    portpool <- liftIO $ PortPool.start kconfigPortPool+    tf <- liftIO $ TempFolder.setup $ kconfigDir </> "temp"+    plugins <- mapM (liftIO . ($ kconfigDir)) mkPlugins     muid <-         case kconfigSetuid of             Nothing -> return Nothing             Just t -> do-                x <- try $+                x <- liftIO $ try $                     case Data.Text.Read.decimal t of                         Right (i, "") -> getUserEntryForID i                         _ -> getUserEntryForName $ T.unpack t@@ -137,24 +165,22 @@             , ascHostManager = hostman             , ascPortPool = portpool             , ascPlugins = plugins-            , ascLog = log-            , ascKeterConfig = kc+            , ascKeterConfig = cfg             }-    appMan <- AppMan.initialize log appStartConfig-    f kc hostman appMan log--launchInitial :: KeterConfig -> AppMan.AppManager -> IO ()-launchInitial kc@KeterConfig {..} appMan = do-    createDirectoryIfMissing True incoming-    bundles0 <- filter isKeter <$> listDirectoryTree incoming-    mapM_ (AppMan.addApp appMan) bundles0+    appMan <- withMappedConfig (const appStartConfig) $ AppMan.initialize+    f hostman appMan -    unless (V.null kconfigBuiltinStanzas) $ AppMan.perform-        appMan-        AIBuiltin-        (AppMan.Reload $ AIData $ BundleConfig kconfigBuiltinStanzas mempty)-  where-    incoming = getIncoming kc+launchInitial :: AppMan.AppManager -> KeterM KeterConfig ()+launchInitial appMan = do+    kc@KeterConfig{..} <- ask+    let incoming = getIncoming kc+    liftIO $ createDirectoryIfMissing True incoming+    bundles0 <- liftIO $ filter isKeter <$> listDirectoryTree incoming+    withMappedConfig (const appMan) $ do+        mapM_ AppMan.addApp bundles0+        unless (V.null kconfigBuiltinStanzas) $ AppMan.perform+            AIBuiltin+            (AppMan.Reload $ AIData $ BundleConfig kconfigBuiltinStanzas mempty)  getIncoming :: KeterConfig -> FilePath getIncoming kc = kconfigDir kc </> "incoming"@@ -162,38 +188,37 @@ isKeter :: FilePath -> Bool isKeter fp = takeExtension fp == ".keter" -startWatching :: KeterConfig -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO ()-startWatching kc appMan log = do+startWatching :: AppMan.AppManager -> KeterM KeterConfig ()+startWatching appMan = do+    incoming <- getIncoming <$> ask     -- File system watching-    wm <- FSN.startManager-    _ <- FSN.watchTree wm (fromString incoming) (const True) $ \e -> do-        e' <--            case e of-                FSN.Removed fp _ _ -> do-                    log $ WatchedFile "removed" (fromFilePath fp)-                    return $ Left $ fromFilePath fp-                FSN.Added fp _ _ -> do-                    log $ WatchedFile "added" (fromFilePath fp)-                    return $ Right $ fromFilePath fp-                FSN.Modified fp _ _ -> do-                    log $ WatchedFile "modified" (fromFilePath fp)-                    return $ Right $ fromFilePath fp-                _ -> do-                    log $ WatchedFile "unknown" []-                    return $ Left []-        case e' of-            Left fp -> when (isKeter fp) $ AppMan.terminateApp appMan $ getAppname fp-            Right fp -> when (isKeter fp) $ AppMan.addApp appMan $ incoming </> fp--    -- Install HUP handler for cases when inotify cannot be used.-    void $ flip (installHandler sigHUP) Nothing $ Catch $ do-        bundles <- fmap (filter isKeter) $ listDirectoryTree incoming-        newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do-            time <- modificationTime <$> getFileStatus bundle-            return (getAppname bundle, (bundle, time))-        AppMan.reloadAppList appMan newMap-  where-    incoming = getIncoming kc+    wm <- liftIO FSN.startManager+    withMappedConfig (const appMan) $ withRunInIO $ \rio -> do+        _ <- FSN.watchTree wm (fromString incoming) (const True) $ \e -> do+                e' <-+                    case e of+                        FSN.Removed fp _ _ -> do+                            rio $ $logInfo $ "Watched file removed: " <> T.pack (fromFilePath fp)+                            return $ Left $ fromFilePath fp+                        FSN.Added fp _ _ -> do+                            rio $ $logInfo $ "Watched file added: " <> T.pack (fromFilePath fp)+                            return $ Right $ fromFilePath fp+                        FSN.Modified fp _ _ -> do+                            rio $ $logInfo $ "Watched file modified: " <> T.pack (fromFilePath fp)+                            return $ Right $ fromFilePath fp+                        _ -> do+                            rio $ $logInfo $ "Watched file unknown" <> T.pack mempty+                            return $ Left []+                rio $ case e' of+                    Left fp -> when (isKeter fp) $ AppMan.terminateApp $ getAppname fp+                    Right fp -> when (isKeter fp) $ AppMan.addApp $ incoming </> fp+        -- Install HUP handler for cases when inotify cannot be used.+        void $ flip (installHandler sigHUP) Nothing $ Catch $ do+            bundles <- fmap (filter isKeter) $ listDirectoryTree incoming+            newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do+                time <- modificationTime <$> getFileStatus bundle+                return (getAppname bundle, (bundle, time))+            rio $ AppMan.reloadAppList newMap   -- compatibility with older versions of fsnotify which used@@ -219,10 +244,14 @@              return [fp1]            ) (filter (\x -> x /= "." && x /= "..") dir) -startListening :: (LogMessage -> IO ()) -> KeterConfig -> HostMan.HostManager -> IO ()-startListening log config hostman = do-    settings <- Proxy.makeSettings log config hostman-    runAndBlock (kconfigListeners config) $ Proxy.reverseProxy settings+startListening :: HostMan.HostManager -> KeterM KeterConfig ()+startListening hostman = do+    cfg@KeterConfig{..} <- ask+    logger <- askLoggerIO+    settings <- Proxy.makeSettings hostman+    withMappedConfig (const settings) $ withRunInIO $ \rio ->+        liftIO $ runAndBlock kconfigListeners $ \ls -> +            rio $ Proxy.reverseProxy ls  runAndBlock :: NonEmptyVector a             -> (a -> IO ())

@@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-} -- | Manages a pool of available ports and allocates them. module Keter.PortPool     ( -- * Types@@ -13,9 +14,14 @@     ) where  import           Keter.Common+import           Keter.Context+import           Data.Text           (pack) import           Control.Applicative     ((<$>)) import           Control.Concurrent.MVar import           Control.Exception+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.IO.Unlift (withRunInIO)+import           Control.Monad.Logger import           Keter.Config import           Network.Socket import           Prelude                 hiding (log)@@ -28,28 +34,31 @@ newtype PortPool = PortPool (MVar PPState)  -- | Gets an unassigned port number.-getPort :: (LogMessage -> IO ())-        -> PortPool-        -> IO (Either SomeException Port)-getPort log (PortPool mstate) =-    modifyMVar mstate loop+getPort :: PortPool+        -> KeterM cfg (Either SomeException Port)+getPort (PortPool mstate) =+    withRunInIO $ \rio -> modifyMVar mstate (rio . loop)   where-    loop :: PPState -> IO (PPState, Either SomeException Port)+    removePortMsg p = pack $+        "Port in use, removing from port pool: "+        ++ show p++    loop :: PPState -> KeterM cfg (PPState, Either SomeException Port)     loop PPState {..} =         case ppAvail of             p:ps -> do                 let next = PPState ps ppRecycled-                res <- try $ listenOn $ show p+                res <- liftIO $ try $ listenOn $ show p                 case res of                     Left (_ :: SomeException) -> do-                        log $ RemovingPort p+                        $logInfo $ removePortMsg p                         loop next                     Right socket' -> do-                        res' <- try $ close socket'+                        res' <- liftIO $ try @SomeException $ close socket'                         case res' of                             Left e -> do-                                $logEx log e-                                log $ RemovingPort p+                                $logError $ pack $ show e+                                $logInfo $ removePortMsg p                                 loop next                             Right () -> return (next, Right p)             [] ->

@@ -17,6 +17,8 @@ import           Blaze.ByteString.Builder          (copyByteString, toByteString) import           Blaze.ByteString.Builder.Html.Word(fromHtmlEscapedByteString) import           Control.Applicative               ((<$>), (<|>))+import           Control.Monad.Reader              (ask)+import           Control.Monad.IO.Unlift           (withRunInIO) import           Control.Monad.IO.Class            (liftIO) import qualified Data.ByteString                   as S import qualified Data.ByteString.Char8             as S8@@ -24,6 +26,7 @@ import           Network.Wai.Middleware.Gzip       (def) #endif import           Data.Monoid                       (mappend, mempty)+import           Data.Text                         (pack) import           Data.Text.Encoding                (decodeUtf8With, encodeUtf8) import           Data.Text.Encoding.Error          (lenientDecode) import qualified Data.Vector                       as V@@ -52,6 +55,7 @@ import           Data.ByteString            (ByteString) import Keter.Common import           System.FilePath            (FilePath)+import           Control.Monad.Logger import           Control.Exception          (SomeException) import           Network.HTTP.Types                (mkStatus,                                                     status301, status302,@@ -68,6 +72,7 @@ import           WaiAppStatic.Listing              (defaultListing) import qualified Network.TLS as TLS import qualified System.Directory as Dir+import Keter.Context  #if !MIN_VERSION_http_reverse_proxy(0,6,0) defaultWaiProxySettings = def@@ -87,30 +92,29 @@   , psUnkownHost     :: ByteString -> ByteString   , psMissingHost    :: ByteString   , psProxyException :: ByteString-  , psLogException   :: Wai.Request -> SomeException -> IO ()   } -makeSettings :: (LogMessage -> IO ()) -> KeterConfig -> HostMan.HostManager -> IO ProxySettings-makeSettings log KeterConfig {..} hostman = do-    psManager <- HTTP.newManager HTTP.tlsManagerSettings+makeSettings :: HostMan.HostManager -> KeterM KeterConfig ProxySettings+makeSettings hostman = do+    KeterConfig{..} <- ask+    psManager <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings     psMissingHost <- case kconfigMissingHostResponse of       Nothing -> pure defaultMissingHostBody-      Just x -> taggedReadFile "unknown-host-response-file" x+      Just x -> liftIO $ taggedReadFile "unknown-host-response-file" x     psUnkownHost <- case kconfigUnknownHostResponse  of                 Nothing -> pure defaultUnknownHostBody-                Just x -> const <$> taggedReadFile "missing-host-response-file" x+                Just x ->  fmap const $ liftIO $ taggedReadFile "missing-host-response-file" x     psProxyException <- case kconfigProxyException of                 Nothing -> pure defaultProxyException-                Just x -> taggedReadFile "proxy-exception-response-file" x+                Just x -> liftIO $ taggedReadFile "proxy-exception-response-file" x+    -- calculate the number of microseconds since the+    -- configuration option is in milliseconds+    let psConnectionTimeBound = kconfigConnectionTimeBound * 1000+    let psIpFromHeader = kconfigIpFromHeader     pure $ MkProxySettings{..}     where-        psLogException a b = log $ ProxyException a b         psHostLookup = HostMan.lookupAction hostman . CI.mk -        -- | calculate the number of microseconds since the-        --   configuration option is in milliseconds-        psConnectionTimeBound = kconfigConnectionTimeBound * 1000-        psIpFromHeader   = kconfigIpFromHeader  taggedReadFile :: String -> FilePath -> IO ByteString taggedReadFile tag file = do@@ -119,20 +123,23 @@           wd <- Dir.getCurrentDirectory           error $ "could not find " <> tag <> " on path '" <> file <> "' with working dir '" <> wd <> "'" -reverseProxy :: ProxySettings -> ListeningPort -> IO ()-reverseProxy settings listener =-    run $ gzip def{gzipFiles = GzipPreCompressed GzipIgnore} $ withClient isSecure settings+reverseProxy :: ListeningPort -> KeterM ProxySettings ()+reverseProxy listener = do+  settings <- ask+  let (run, isSecure) =+          case listener of+              LPInsecure host port -> +                  (liftIO . Warp.runSettings (warp host port), False)+              LPSecure host port cert chainCerts key session -> +                  (liftIO . WarpTLS.runTLS+                      (connectClientCertificates (psHostLookup settings) session $ WarpTLS.tlsSettingsChain+                          cert+                          (V.toList chainCerts)+                          key)+                      (warp host port), True)+  withClient isSecure >>= run . gzip def{gzipFiles = GzipPreCompressed GzipIgnore}   where     warp host port = Warp.setHost host $ Warp.setPort port Warp.defaultSettings-    (run, isSecure) =-        case listener of-            LPInsecure host port -> (Warp.runSettings (warp host port), False)-            LPSecure host port cert chainCerts key session -> (WarpTLS.runTLS-                (connectClientCertificates (psHostLookup settings) session $ WarpTLS.tlsSettingsChain-                    cert-                    (V.toList chainCerts)-                    key)-                (warp host port), True)  connectClientCertificates :: (ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))) -> Bool -> WarpTLS.TLSSettings -> WarpTLS.TLSSettings connectClientCertificates hl session s =@@ -148,37 +155,37 @@           , WarpTLS.tlsSessionManagerConfig = if session then (Just TLSSession.defaultConfig) else Nothing }  - withClient :: Bool -- ^ is secure?-           -> ProxySettings-           -> Wai.Application-withClient isSecure MkProxySettings {..} =-    waiProxyToSettings-       (error "First argument to waiProxyToSettings forced, even thought wpsGetDest provided")-       defaultWaiProxySettings-        { wpsSetIpHeader =-            if useHeader-                then SIHFromHeader-                else SIHFromSocket-        ,  wpsGetDest = Just getDest-        ,  wpsOnExc = handleProxyException psLogException psProxyException-        } psManager+           -> KeterM ProxySettings Wai.Application+withClient isSecure = do+    cfg@MkProxySettings{..} <- ask+    let useHeader = psIpFromHeader+    withRunInIO $ \rio ->+        pure $ waiProxyToSettings+           (error "First argument to waiProxyToSettings forced, even thought wpsGetDest provided")+           defaultWaiProxySettings+            { wpsSetIpHeader =+                if useHeader+                    then SIHFromHeader+                    else SIHFromSocket+            ,  wpsGetDest = Just (getDest cfg)+            ,  wpsOnExc = handleProxyException (\app e -> rio $ logException app e) psProxyException+            } psManager   where-    useHeader :: Bool-    useHeader = psIpFromHeader+    logException :: Wai.Request -> SomeException -> KeterM ProxySettings ()+    logException a b = logErrorN $ pack $ +      "Got a proxy exception on request " <> show a <> " with exception "  <> show b -    bound :: Int-    bound = psConnectionTimeBound -    getDest :: Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)-    getDest req =+    getDest :: ProxySettings -> Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)+    getDest cfg@MkProxySettings{..} req =         case Wai.requestHeaderHost req of             Nothing -> do               return (defaultLocalWaiProxySettings, WPRResponse $ missingHostResponse psMissingHost)-            Just host -> processHost req host+            Just host -> processHost cfg req host -    processHost :: Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)-    processHost req host = do+    processHost :: ProxySettings -> Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)+    processHost cfg@MkProxySettings{..} req host = do         -- Perform two levels of lookup. First: look up the entire host. If         -- that fails, try stripping off any port number and try again.         mport <- liftIO $ do@@ -194,11 +201,11 @@             Nothing -> do -- we don't know the host that was asked for               return (defaultLocalWaiProxySettings, WPRResponse $ unknownHostResponse host (psUnkownHost host))             Just ((action, requiresSecure), _)-                | requiresSecure && not isSecure -> performHttpsRedirect host req-                | otherwise -> performAction psManager isSecure bound req action+                | requiresSecure && not isSecure -> performHttpsRedirect cfg host req+                | otherwise -> performAction psManager isSecure psConnectionTimeBound req action -    performHttpsRedirect host =-        return . (addjustGlobalBound bound Nothing,) . WPRResponse . redirectApp config+    performHttpsRedirect MkProxySettings{..} host =+        return . (addjustGlobalBound psConnectionTimeBound Nothing,) . WPRResponse . redirectApp config       where         host' = CI.mk $ decodeUtf8With lenientDecode host         config = RedirectConfig

@@ -1,27 +1,28 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}  module Main where -import Network.HTTP.Client (defaultManagerSettings, managerResponseTimeout) import Network.HTTP.Types.Status(ok200) import qualified Network.Wai.Handler.Warp as Warp import Keter.Config.V10-import           Control.Concurrent        (forkIO)+import           Control.Concurrent        (forkIO, threadDelay) import Data.Maybe (isJust) import Keter.LabelMap as LM import Test.Tasty import Test.Tasty.HUnit import Control.Monad+import Control.Monad.Reader+import Control.Monad.Logger import           Control.Exception          (SomeException) import           Network.HTTP.Conduit              (Manager)-import Control.Lens-import Network.Wreq(Options) import Data.ByteString(ByteString) import qualified Network.Wreq as Wreq import Control.Monad.STM import Control.Concurrent.STM.TQueue import qualified Network.Wai                       as Wai import qualified Network.HTTP.Conduit      as HTTP+import Keter.Context import Keter.Proxy  main :: IO ()@@ -32,8 +33,8 @@   testGroup     "Tests"     [ testCase "Subdomain Integrity" caseSubdomainIntegrity-    , testCase "Head then post doesn't crash" headThenPostNoCrash     , testCase "Wildcard Domains" caseWildcards+    , testCase "Head then post doesn't crash" headThenPostNoCrash     ]  caseSubdomainIntegrity :: IO ()@@ -58,15 +59,21 @@ headThenPostNoCrash = do   manager <- HTTP.newManager HTTP.tlsManagerSettings   exceptions <- newTQueueIO-+     forkIO $ do     Warp.run 6781 $ \req resp -> do       void $ Wai.strictRequestBody req       resp $ Wai.responseLBS ok200 [] "ok" -  forkIO $ do-    reverseProxy (settings exceptions manager) $ LPInsecure "*" 6780+  forkIO $ +    flip runReaderT (settings manager) $ +      flip runLoggingT (\_ _ _ msg -> atomically $ writeTQueue exceptions msg) $+        filterLogger isException $ +          runKeterM $ +            reverseProxy $ LPInsecure "*" 6780 +  threadDelay 0_100_000+   res <- Wreq.head_ "http://localhost:6780"    void $ Wreq.post "http://localhost:6780" content@@ -76,16 +83,19 @@   where     content :: ByteString     content = "a"+    +    -- For 'reverseProxy', only exceptions (and strictly exceptions!) are logged as LevelError.+    isException :: LogSource -> LogLevel -> Bool+    isException _ LevelError = True+    isException _ _ = False -    settings :: TQueue (Wai.Request, SomeException) ->  Manager -> ProxySettings-    settings expections manager = MkProxySettings {+    settings :: Manager -> ProxySettings+    settings manager = MkProxySettings {         psHostLookup     = const $ pure $ Just ((PAPort 6781 Nothing, False), error "unused tls certificate")       , psManager        = manager       , psUnkownHost     = const ""       , psMissingHost    = ""       , psProxyException = ""-      , psLogException   = \req exception ->-          atomically $ writeTQueue expections (req, exception)       , psIpFromHeader   = False       , psConnectionTimeBound = 5 * 60 * 1000       }