keter 1.9 → 2.0

raw patch · 45 files changed

+4506/−4432 lines, 45 filesdep +tastydep +tasty-hunitdep −data-defaultdep −hspecdep ~http-clientPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty, tasty-hunit

Dependencies removed: data-default, hspec

Dependency ranges changed: http-client

API changes (from Hackage documentation)

Files

• ChangeLog.md +16/−0
• Codec/Archive/TempTarball.hs +0/−117
• Data/Aeson/KeyHelper.hs +0/−33
• Data/Conduit/LogFile.hs +0/−140
• Data/Conduit/Process/Unix.hs +0/−351
• Data/Yaml/FilePath.hs +0/−74
• Keter/App.hs +0/−729
• Keter/AppManager.hs +0/−284
• Keter/Cli.hs +0/−95
• Keter/HostManager.hs +0/−181
• Keter/LabelMap.hs +0/−315
• Keter/Main.hs +0/−236
• Keter/Plugin/Postgres.hs +0/−198
• Keter/PortPool.hs +0/−86
• Keter/Proxy.hs +0/−320
• Keter/Types.hs +0/−26
• Keter/Types/Common.hs +0/−237
• Keter/Types/Middleware.hs +0/−99
• Keter/Types/V04.hs +0/−157
• Keter/Types/V10.hs +0/−478
• Network/HTTP/ReverseProxy/Rewrite.hs +0/−231
• keter.cabal +19/−18
• main/keter.hs +0/−26
• src/Keter/Aeson/KeyHelper.hs +33/−0
• src/Keter/App.hs +734/−0
• src/Keter/AppManager.hs +290/−0
• src/Keter/Cli.hs +95/−0
• src/Keter/Common.hs +229/−0
• src/Keter/Conduit/LogFile.hs +140/−0
• src/Keter/Conduit/Process/Unix.hs +351/−0
• src/Keter/Config.hs +26/−0
• src/Keter/Config/Middleware.hs +99/−0
• src/Keter/Config/V04.hs +159/−0
• src/Keter/Config/V10.hs +481/−0
• src/Keter/HostManager.hs +185/−0
• src/Keter/LabelMap.hs +315/−0
• src/Keter/Main.hs +238/−0
• src/Keter/Plugin/Postgres.hs +209/−0
• src/Keter/PortPool.hs +87/−0
• src/Keter/Proxy.hs +321/−0
• src/Keter/Rewrite.hs +223/−0
• src/Keter/TempTarball.hs +117/−0
• src/Keter/Yaml/FilePath.hs +74/−0
• src/main/keter.hs +25/−0
• test/Spec.hs +40/−1

@@ -1,3 +1,19 @@+## 2.0+++ Improve missing sudo error messages in postgres plugin.++ Reorganized most Haskell source files into /src.++ Dropped support for http-client < 0.5.0.++ Removed 'default' package.++ All "Data" modules are now "Keter" modules.++ Testing library switched from "hspec" to "tasty".+* Move Network.Http.ReverseProxy.Rewrite into Keter.Rewrite+* Move Codec.Archive.TempTarball into Keter.TempTarball+* Hide Keter.Aeson.KeyHelper+* Stop re-exporting common and rewrite from types+* Common no longer re-exports half of Haskell+* Rename Types to Config+* Move Common out of Config into root+ ## 1.9  + Update status code of missing host responses.

@@ -1,117 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}--- | Handles allocation of temporary directories and unpacking of bundles into--- them. Sets owner and group of all created files and directories as--- necessary.-module Codec.Archive.TempTarball-    ( TempFolder-    , setup-    , unpackTempTar-    ) where--import qualified Codec.Archive.Tar         as Tar-import qualified Codec.Archive.Tar.Check   as Tar-import qualified Codec.Archive.Tar.Entry   as Tar-import           Codec.Compression.GZip    (decompress)-import           Control.Exception         (bracket, bracketOnError, throwIO)-import           Control.Monad             (unless, when)-import qualified Data.ByteString.Lazy      as L-import           Data.ByteString.Unsafe    (unsafeUseAsCStringLen)-import qualified Data.IORef                as I-import           Data.Monoid               ((<>))-import           Data.Text                 (Text, pack, unpack)-import           Data.Word                 (Word)-import           System.FilePath ((</>))-import qualified System.FilePath           as F-import qualified System.Directory          as D-import           Foreign.Ptr               (castPtr)-import           System.Posix.Files        (setFdOwnerAndGroup,-                                            setOwnerAndGroup)-import           System.Posix.IO           (FdOption (CloseOnExec), closeFd,-                                            createFile, fdWriteBuf, setFdOption)-import           System.Posix.Types        (GroupID, UserID)--data TempFolder = TempFolder-    { tfRoot    :: FilePath-    , tfCounter :: I.IORef Word-    }--setup :: FilePath -> IO TempFolder-setup fp = do-    e <- D.doesDirectoryExist fp-    when e $ D.removeDirectoryRecursive fp-    D.createDirectoryIfMissing True fp-    c <- I.newIORef minBound-    return $ TempFolder fp c--getFolder :: Maybe (UserID, GroupID)-          -> TempFolder-          -> Text -- ^ prefix for folder name-          -> IO FilePath-getFolder muid TempFolder {..} appname = do-    !i <- I.atomicModifyIORef tfCounter $ \i -> (succ i, i)-    let fp = tfRoot </> unpack (appname <> "-" <> pack (show i))-    D.createDirectoryIfMissing True fp-    case muid of-        Nothing -> return ()-        Just (uid, gid) -> setOwnerAndGroup fp uid gid-    return fp--unpackTempTar :: Maybe (UserID, GroupID)-              -> TempFolder-              -> FilePath -- ^ bundle-              -> Text -- ^ prefix for folder name-              -> (FilePath -> IO a)-              -> IO a-unpackTempTar muid tf bundle appname withDir = do-    lbs <- L.readFile bundle-    bracketOnError (getFolder muid tf appname) D.removeDirectoryRecursive $ \dir -> do-        unpackTar muid dir $ Tar.read $ decompress lbs-        withDir dir--unpackTar :: Maybe (UserID, GroupID)-          -> FilePath-          -> Tar.Entries Tar.FormatError-          -> IO ()-unpackTar muid dir =-    loop . Tar.checkSecurity-  where-    loop Tar.Done = return ()-    loop (Tar.Fail e) = either throwIO throwIO e-    loop (Tar.Next e es) = go e >> loop es--    go e = do-        let fp = dir </> Tar.entryPath e-        case Tar.entryContent e of-            Tar.NormalFile lbs _ -> do-                case muid of-                    Nothing -> D.createDirectoryIfMissing True $ F.takeDirectory fp-                    Just (uid, gid) -> createTreeUID uid gid $ F.takeDirectory fp-                let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do-                        _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len)-                        return ()-                bracket-                    (do-                        fd <- createFile fp $ Tar.entryPermissions e-                        setFdOption fd CloseOnExec True-                        case muid of-                            Nothing -> return ()-                            Just (uid, gid) -> setFdOwnerAndGroup fd uid gid-                        return fd)-                    closeFd-                    (\fd -> mapM_ (write fd) (L.toChunks lbs))-            _ -> return ()---- | Create a directory tree, setting the uid and gid of all newly created--- folders.-createTreeUID :: UserID -> GroupID -> FilePath -> IO ()-createTreeUID uid gid =-    go-  where-    go fp = do-        exists <- D.doesDirectoryExist fp-        unless exists $ do-            go $ F.takeDirectory fp-            D.createDirectoryIfMissing False fp-            setOwnerAndGroup fp uid gid

@@ -1,33 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoImplicitPrelude #-}--- | Utilities for dealing with Aeson version update--module Data.Aeson.KeyHelper-  ( module KeyMap-  , toKey-  , toText-  ) where--import Prelude (id)-import qualified Data.Text                   as Text--#if MIN_VERSION_aeson (2,0,0)-import qualified Data.Aeson.Key              as Key-import Data.Aeson.KeyMap                     as KeyMap hiding (map)--toKey :: Text.Text -> Key.Key-toKey = Key.fromText--toText :: Key.Key -> Text.Text-toText = Key.toText--#else-import Data.HashMap.Strict                   as KeyMap hiding (map)--toKey :: Text.Text -> Text.Text-toKey = id--toText :: Text.Text -> Text.Text-toText = id--#endif

@@ -1,140 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Data.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

@@ -1,351 +0,0 @@-{-# LANGUAGE CPP                      #-}-{-# LANGUAGE DeriveDataTypeable       #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings        #-}-{-# LANGUAGE ScopedTypeVariables      #-}--module Data.Conduit.Process.Unix-    ( -- * Process tracking-      -- $processTracker--      -- ** Types-      ProcessTracker-      -- ** Functions-    , initProcessTracker--      -- * Monitored process-    , MonitoredProcess-    , monitorProcess-    , terminateMonitoredProcess-    , printStatus-    ) where--import           Data.Text(Text, pack)-import           Control.Applicative             ((<$>), (<*>), pure)-import           Control.Arrow                   ((***))-import           Control.Concurrent              (forkIO)-import           Control.Concurrent              (threadDelay)-import           Control.Concurrent.MVar         (MVar, modifyMVar, modifyMVar_,-                                                  newEmptyMVar, newMVar,-                                                  putMVar, readMVar, swapMVar,-                                                  takeMVar, tryReadMVar)-import           Control.Exception               (Exception, SomeException,-                                                  bracketOnError, finally,-                                                  handle, mask_,-                                                  throwIO, try)-import           Control.Monad                   (void)-import           Data.ByteString                 (ByteString)-import qualified Data.ByteString.Char8           as S8-import           Data.Conduit                    (ConduitM, (.|), runConduit)-import           Data.Conduit.Binary             (sinkHandle, sourceHandle)-import qualified Data.Conduit.List               as CL-import           Data.IORef                      (IORef, newIORef, readIORef,-                                                  writeIORef)-import           Data.Time                       (getCurrentTime)-import           Data.Time                       (diffUTCTime)-import           Data.Typeable                   (Typeable)-import           Foreign.C.Types-import           Prelude                         (Bool (..), Either (..), IO,-                                                  Maybe (..), Monad (..), Show,-                                                  const, error,-                                                  map, maybe, show,-                                                  ($), ($!), (*), (<),-                                                  (==))-import           System.Exit                     (ExitCode)-import           System.IO                       (hClose)-import           System.Posix.IO.ByteString      ( closeFd, createPipe,-                                                  fdToHandle)-import           System.Posix.Signals            (sigKILL, signalProcess)-import           System.Posix.Types              (CPid (..))-import           System.Process                  (CmdSpec (..), CreateProcess (..),-                                                  StdStream (..), createProcess,-                                                  terminateProcess, waitForProcess,-                                                  getPid)-import           System.Process.Internals        (ProcessHandle (..),-                                                  ProcessHandle__ (..))-import Data.Monoid ((<>)) -- sauron--processHandleMVar :: ProcessHandle -> MVar ProcessHandle__-#if MIN_VERSION_process(1, 6, 0)-processHandleMVar (ProcessHandle m _ _) = m-#elif MIN_VERSION_process(1, 2, 0)-processHandleMVar (ProcessHandle m _) = m-#else-processHandleMVar (ProcessHandle m) = m-#endif--withProcessHandle_-        :: ProcessHandle-        -> (ProcessHandle__ -> IO ProcessHandle__)-        -> IO ()-withProcessHandle_ ph io = modifyMVar_ (processHandleMVar ph) io---- | Kill a process by sending it the KILL (9) signal.------ Since 0.1.0-killProcess :: ProcessHandle -> IO ()-killProcess ph = withProcessHandle_ ph $ \p_ ->-    case p_ of-        ClosedHandle _ -> return p_-        OpenHandle h -> do-            signalProcess sigKILL h-            return p_--ignoreExceptions :: IO () -> IO ()-ignoreExceptions = handle (\(_ :: SomeException) -> return ())---- $processTracker------ Ensure that child processes are killed, regardless of how the parent process exits.------ The technique used here is:------ * Create a pipe.------ * Fork a new child process that listens on the pipe.------ * In the current process, send updates about processes that should be auto-killed.------ * When the parent process dies, listening on the pipe in the child process will get an EOF.------ * When the child process receives that EOF, it kills all processes it was told to auto-kill.------ This code was originally written for Keter, but was moved to unix-process--- conduit in the 0.2.1 release.--foreign import ccall unsafe "launch_process_tracker"-    c_launch_process_tracker :: IO CInt--foreign import ccall unsafe "track_process"-    c_track_process :: ProcessTracker -> CPid -> CInt -> IO ()---- | Represents the child process which handles process cleanup.------ Since 0.2.1-newtype ProcessTracker = ProcessTracker CInt---- | Represents a child process which is currently being tracked by the cleanup--- child process.------ Since 0.2.1-data TrackedProcess = TrackedProcess !ProcessTracker !(IORef MaybePid) !(IO ExitCode)--data MaybePid = NoPid | Pid !CPid---- | Fork off the child cleanup process.------ This will ideally only be run once for your entire application.------ Since 0.2.1-initProcessTracker :: IO ProcessTracker-initProcessTracker = do-    i <- c_launch_process_tracker-    if i == -1-        then throwIO CannotLaunchProcessTracker-        else return $! ProcessTracker i---- | Since 0.2.1-data ProcessTrackerException = CannotLaunchProcessTracker-    deriving (Show, Typeable)-instance Exception ProcessTrackerException---- | Begin tracking the given process. If the 'ProcessHandle' refers to a--- closed process, no tracking will occur. If the process is closed, then it--- will be untracked automatically.------ Note that you /must/ compile your program with @-threaded@; see--- 'waitForProcess'.------ Since 0.2.1-trackProcess :: ProcessTracker -> ProcessHandle -> IO TrackedProcess-trackProcess pt ph = mask_ $ do-    mpid <- readMVar $ processHandleMVar ph-    mpid' <- case mpid of-        ClosedHandle{} -> return NoPid-        OpenHandle pid -> do-            c_track_process pt pid 1-            return $ Pid pid-    ipid <- newIORef mpid'-    baton <- newEmptyMVar-    let tp = TrackedProcess pt ipid (takeMVar baton)-    case mpid' of-        NoPid -> return ()-        Pid _ -> void $ forkIO $ do-            waitForProcess ph >>= putMVar baton-            untrackProcess tp-    return $! tp---- | Explicitly remove the given process from the tracked process list in the--- cleanup process.------ Since 0.2.1-untrackProcess :: TrackedProcess -> IO ()-untrackProcess (TrackedProcess pt ipid _) = mask_ $ do-    mpid <- readIORef ipid-    case mpid of-        NoPid -> return ()-        Pid pid -> do-            c_track_process pt pid 0-            writeIORef ipid NoPid---- | Fork and execute a subprocess, sending stdout and stderr to the specified--- rotating log.------ Since 0.2.1-forkExecuteLog :: ByteString -- ^ command-               -> [ByteString] -- ^ args-               -> Maybe [(ByteString, ByteString)] -- ^ environment-               -> Maybe ByteString -- ^ working directory-               -> 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-    setupPipe-    cleanupPipes-    usePipes-  where-    setupPipe = bracketOnError-        createPipe-        (\(x, y) -> closeFd x `finally` closeFd y)-        (\(x, y) -> (,) <$> fdToHandle x <*> fdToHandle y)-    cleanupPipes (x, y) = hClose x `finally` hClose y--    usePipes pipes@(readerH, writerH) = do-        (min, _, _, ph) <- createProcess CreateProcess-            { cmdspec = RawCommand (S8.unpack cmd) (map S8.unpack args)-            , cwd = S8.unpack <$> mwdir-            , env = map (S8.unpack *** S8.unpack) <$> menv-            , std_in = maybe Inherit (const CreatePipe) mstdin-            , std_out = UseHandle writerH-            , std_err = UseHandle writerH-            , close_fds = True-            , create_group = True-#if MIN_VERSION_process(1, 5, 0)-            , use_process_jobs = False-#endif-#if MIN_VERSION_process(1, 2, 0)-            , delegate_ctlc = False-#endif-#if MIN_VERSION_process(1, 3, 0)-            , detach_console = True-            , create_new_console = False-            , new_session = True-#endif-#if MIN_VERSION_process(1, 4, 0)-            , child_group = Nothing-            , child_user = Nothing-#endif-            }-        ignoreExceptions $ addAttachMessage pipes ph-        void $ forkIO $ ignoreExceptions $-            (runConduit $ sourceHandle readerH .| CL.mapM_ rlog) `finally` hClose readerH-        case (min, mstdin) of-            (Just h, Just source) -> void $ forkIO $ ignoreExceptions $-                (runConduit $ source .| sinkHandle h) `finally` hClose h-            (Nothing, Nothing) -> return ()-            _ -> error $ "Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog"-        return ph--    addAttachMessage pipes ph = withProcessHandle_ ph $ \p_ -> do-        now <- getCurrentTime-        case p_ of-            ClosedHandle ec -> do-                rlog $ S8.concat-                    [ "\n\n"-                    , S8.pack $ show now-                    , ": Process immediately died with exit code "-                    , S8.pack $ show ec-                    , "\n\n"-                    ]-                cleanupPipes pipes-            OpenHandle h -> do-                rlog $ S8.concat-                    [ "\n\n"-                    , S8.pack $ show now-                    , ": Attached new process "-                    , S8.pack $ show h-                    , "\n\n"-                    ]-        return p_--data Status = NeedsRestart | NoRestart | Running ProcessHandle---- | Run the given command, restarting if the process dies.-monitorProcess-    :: (ByteString -> IO ()) -- ^ log-    -> ProcessTracker-    -> Maybe S8.ByteString -- ^ setuid-    -> S8.ByteString -- ^ executable-    -> S8.ByteString -- ^ working directory-    -> [S8.ByteString] -- ^ command line parameter-    -> [(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---- | Abstract type containing information on a process which will be restarted.-newtype MonitoredProcess = MonitoredProcess (MVar Status)--printStatus :: MonitoredProcess -> IO Text-printStatus (MonitoredProcess mstatus) = do-  mStatus <- tryReadMVar mstatus-  case mStatus of-    Nothing -> pure "no status set process"-    Just NeedsRestart -> pure "needs-restart process"-    Just NoRestart -> pure "no-restart process"-    Just (Running running) -> do-      x <- getPid running-      case x of-        Just y -> pure ("running process '" <> pack (show y) <> "'")-        Nothing -> pure "just closed process"---- | Terminate the process and prevent it from being restarted.-terminateMonitoredProcess :: MonitoredProcess -> IO ()-terminateMonitoredProcess (MonitoredProcess mstatus) = do-    status <- swapMVar mstatus NoRestart-    case status of-        Running pid -> do-            terminateProcess pid-            threadDelay 1000000-            killProcess pid-        _ -> return ()

@@ -1,74 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--- | Utilities for dealing with YAML config files which contain relative file--- paths.-module Data.Yaml.FilePath-    ( decodeFileRelative-    , lookupBase-    , lookupBaseMaybe-    , BaseDir-    , ParseYamlFile (..)-    , NonEmptyVector (..)-    ) where--import Control.Applicative ((<$>))-import Data.Yaml (decodeFileEither, ParseException (AesonException), parseJSON)-import Prelude (($!), ($), Either (..), return, IO, (.), (>>=), Maybe (..), maybe, mapM, Ord, fail, FilePath)-import Data.Aeson.KeyHelper as AK-import Data.Aeson.Types ((.:), (.:?), Object, Parser, Value, parseEither)-import Data.Text (Text, unpack)-import qualified Data.Set as Set-import qualified Data.Vector as V-import System.FilePath (takeDirectory, (</>))---- | The directory from which we're reading the config file.-newtype BaseDir = BaseDir FilePath---- | Parse a config file, using the 'ParseYamlFile' typeclass.-decodeFileRelative :: ParseYamlFile a-                   => FilePath-                   -> IO (Either ParseException a)-decodeFileRelative fp = do-    evalue <- decodeFileEither fp-    return $! case evalue of-        Left e -> Left e-        Right value ->-            case parseEither (parseYamlFile basedir) value of-                Left s -> Left $! AesonException s-                Right x -> Right $! x-  where-    basedir = BaseDir $ takeDirectory fp---- | A replacement for the @.:@ operator which will both parse a file path and--- apply the relative file logic.-lookupBase :: ParseYamlFile a => BaseDir -> Object -> Text -> Parser a-lookupBase basedir o k = (o .: k') >>= parseYamlFile basedir-  where-    k' = AK.toKey k---- | A replacement for the @.:?@ operator which will both parse a file path and--- apply the relative file logic.-lookupBaseMaybe :: ParseYamlFile a => BaseDir -> Object -> Text -> Parser (Maybe a)-lookupBaseMaybe basedir o k = (o .:? k') >>= maybe (return Nothing) ((Just <$>) . parseYamlFile basedir)-  where-    k' = AK.toKey k---- | A replacement for the standard @FromJSON@ typeclass which can handle relative filepaths.-class ParseYamlFile a where-    parseYamlFile :: BaseDir -> Value -> Parser a--instance ParseYamlFile FilePath where-    parseYamlFile (BaseDir dir) o = ((dir </>) . unpack) <$> parseJSON o-instance (ParseYamlFile a, Ord a) => ParseYamlFile (Set.Set a) where-    parseYamlFile base o = parseJSON o >>= ((Set.fromList <$>) . mapM (parseYamlFile base))-instance ParseYamlFile a => ParseYamlFile (V.Vector a) where-    parseYamlFile base o = parseJSON o >>= ((V.fromList <$>) . mapM (parseYamlFile base))--data NonEmptyVector a = NonEmptyVector !a !(V.Vector a)-instance ParseYamlFile a => ParseYamlFile (NonEmptyVector a) where-    parseYamlFile base o = do-        v <- parseYamlFile base o-        if V.null v-            then fail "NonEmptyVector: Expected at least one value"-            else return $ NonEmptyVector (V.head v) (V.tail v)

@@ -1,729 +0,0 @@-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE NamedFieldPuns      #-}--module Keter.App-    ( App-    , AppStartConfig (..)-    , start-    , reload-    , getTimestamp-    , Keter.App.terminate-    , showApp-    ) where--import           Codec.Archive.TempTarball-import           Control.Applicative       ((<$>), (<*>))-import           Control.Arrow             ((***))-import           Control.Concurrent        (forkIO, threadDelay)-import           Control.Concurrent.STM-import           Control.Exception         (IOException, bracketOnError,-                                            throwIO, try, catch)-import           Control.Monad             (void, when, liftM)-import qualified Data.CaseInsensitive      as CI-import           Data.Conduit.LogFile      (RotatingLog)-import qualified Data.Conduit.LogFile      as LogFile-import           Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,-                                            monitorProcess,-                                            terminateMonitoredProcess, printStatus)-import           Data.Foldable             (for_, traverse_)-import           Data.IORef-import qualified Data.Map                  as Map-import           Data.Maybe                (fromMaybe)-import           Data.Monoid               ((<>), mempty)-import qualified Data.Set                  as Set-import           Data.Text                 (pack, unpack)-import           Data.Text.Encoding        (decodeUtf8With, encodeUtf8)-import           Data.Text.Encoding.Error  (lenientDecode)-import qualified Data.Vector               as V-import           Data.Yaml-import           Data.Yaml.FilePath-import System.FilePath ((</>))-import           System.Directory          (canonicalizePath, doesFileExist,-                                            removeDirectoryRecursive)-import           Keter.HostManager         hiding (start)-import           Keter.PortPool            (PortPool, getPort, releasePort)-import           Keter.Types-import           Network.Socket-import           Prelude                   hiding (FilePath)-import           System.Environment        (getEnvironment)-import           System.IO                 (hClose, IOMode(..))-import           System.Posix.Files        (fileAccess)-import           System.Posix.Types        (EpochTime, GroupID, UserID)-import           System.Timeout            (timeout)-import qualified Network.TLS as TLS-import qualified Data.Text.Encoding as Text--data App = App-    { appModTime        :: !(TVar (Maybe EpochTime))-    , appRunningWebApps :: !(TVar [RunningWebApp])-    , appBackgroundApps :: !(TVar [RunningBackgroundApp])-    , appId             :: !AppId-    , appHosts          :: !(TVar (Set Host))-    , appDir            :: !(TVar (Maybe FilePath))-    , appAsc            :: !AppStartConfig-    , appRlog           :: !(TVar (Maybe RotatingLog))-    }-instance Show App where-  show App {appId, ..} = "App{appId=" <> show appId <> "}"---- | within an stm context we can show a lot more then the show instance can do-showApp :: App -> STM Text-showApp App{..} = do-  appModTime' <- readTVar appModTime-  appRunning' <- readTVar appRunningWebApps-  appHosts'   <- readTVar appHosts-  pure $ pack $-    (show appId) <>-    " modtime: " <> (show appModTime') <>  ", webappsRunning: " <>  show appRunning' <> ", hosts: " <> show appHosts'---data RunningWebApp = RunningWebApp-    { rwaProcess            :: !MonitoredProcess-    , rwaPort               :: !Port-    , rwaEnsureAliveTimeOut :: !Int-    }--instance Show RunningWebApp where-  show (RunningWebApp {..})  = "RunningWebApp{rwaPort=" <> show rwaPort <> ", rwaEnsureAliveTimeOut=" <> show rwaEnsureAliveTimeOut <> ",..}"--newtype RunningBackgroundApp = RunningBackgroundApp-    { rbaProcess :: MonitoredProcess-    }--unpackBundle :: AppStartConfig-             -> FilePath-             -> AppId-             -> IO (FilePath, BundleConfig)-unpackBundle AppStartConfig {..} bundle aid = do-    ascLog $ UnpackingBundle bundle-    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-            let yml = dir </> "config" </> "keter.yml"-            exists <- doesFileExist yml-            return $ if exists then yml-                               else dir </> "config" </> "keter.yaml"--        mconfig <- decodeFileRelative configFP-        config <--            case mconfig of-                Right config -> return config-                Left e -> throwIO $ InvalidConfigFile e-        return (dir, config)-  where-    folderName =-        case aid of-            AIBuiltin -> "__builtin__"-            AINamed x -> x--data AppStartConfig = AppStartConfig-    { ascTempFolder     :: !TempFolder-    , ascSetuid         :: !(Maybe (Text, (UserID, GroupID)))-    , ascProcessTracker :: !ProcessTracker-    , ascHostManager    :: !HostManager-    , ascPortPool       :: !PortPool-    , ascPlugins        :: !Plugins-    , ascLog            :: !(LogMessage -> IO ())-    , ascKeterConfig    :: !KeterConfig-    }--withConfig :: AppStartConfig-           -> 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)--withReservations :: AppStartConfig-                 -> 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)--withActions :: AppStartConfig-            -> BundleConfig-            -> ([ WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a)-            -> IO a-withActions asc bconfig f =-    loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty-  where-    -- todo: add loading from relative location-    loadCert (SSL certFile chainCertFiles keyFile) =-         either (const mempty) (TLS.Credentials . (:[]))-            <$> TLS.credentialLoadX509Chain certFile (V.toList chainCertFiles) keyFile-    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))-      where-        hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)-    loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 = do-        cert <- loadCert $ sfconfigSsl sfc-        loop stanzas wacs backs (actions cert)-      where-        actions cert = Map.unions-                $ actions0-                : 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-        loop stanzas wacs backs (actions cert)-      where-        actions cert = Map.unions-                $ actions0-                : 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-        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-  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-    f-  where-    go (Stanza (StanzaWebApp WebAppConfig {..}) _) = do-      isExec waconfigExec-      for_ waconfigEnsureAliveTimeout-        $ \x -> when (x < 1) $ throwIO $ EnsureAliveShouldBeBiggerThenZero x-    go (Stanza (StanzaBackground BackgroundConfig {..}) _) = isExec bgconfigExec-    go _ = return ()--    isExec fp = do-        exists <- doesFileExist fp-        if exists-            then do-                canExec <- fileAccess fp True False True-                if canExec-                    then return ()-                    else throwIO $ FileNotExecutable fp-            else throwIO $ ExecutableNotFound fp--start :: AppStartConfig-      -> 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-            <$> newTVarIO mmodtime-            <*> newTVarIO runningWebapps-            <*> newTVarIO runningBacks-            <*> return aid-            <*> newTVarIO (Map.keysSet actions)-            <*> newTVarIO newdir-            <*> return asc-            <*> return trlog--bracketedMap :: (a -> (b -> IO c) -> IO c)-             -> ([b] -> IO c)-             -> [a]-             -> IO c-bracketedMap with inside =-    loop id-  where-    loop front [] = inside $ front []-    loop front (c:cs) = with c $ \x -> loop (front . (x:)) cs--withWebApps :: AppStartConfig-            -> AppId-            -> BundleConfig-            -> Maybe FilePath-            -> RotatingLog-            -> [WebAppConfig Port]-            -> ([RunningWebApp] -> IO a)-            -> IO a-withWebApps asc aid bconfig mdir rlog configs0 f =-    bracketedMap alloc f configs0-  where-    alloc = launchWebApp asc aid bconfig mdir rlog--launchWebApp :: AppStartConfig-             -> AppId-             -> BundleConfig-             -> Maybe FilePath-             -> RotatingLog-             -> WebAppConfig Port-             -> (RunningWebApp -> IO a)-             -> IO a-launchWebApp AppStartConfig {..} aid BundleConfig {..} mdir rlog WebAppConfig {..} f = do-    otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins-    forwardedEnv <- getForwardedEnv waconfigForwardEnv-    let httpPort  = kconfigExternalHttpPort  ascKeterConfig-        httpsPort = kconfigExternalHttpsPort ascKeterConfig-        (scheme, extport) =-            if waconfigSsl == SSLFalse-                then ("http://",  if httpPort  ==  80 then "" else ':' : show httpPort)-                else ("https://", if httpsPort == 443 then "" else ':' : show httpsPort)-        env = Map.toList $ Map.unions-            -- Ordering chosen specifically to precedence rules: app specific,-            -- plugins, global, and then auto-set Keter variables.-            [ waconfigEnvironment-            , forwardedEnv-            , Map.fromList otherEnv-            , kconfigEnvironment ascKeterConfig-            , Map.singleton "PORT" $ pack $ show waconfigPort-            , Map.singleton "APPROOT" $ scheme <> CI.original waconfigApprootHost <> pack extport-            ]-    exec <- canonicalizePath waconfigExec-    bracketOnError-        (monitorProcess-            (ascLog . OtherMessage . decodeUtf8With lenientDecode)-            ascProcessTracker-            (encodeUtf8 . fst <$> ascSetuid)-            (encodeUtf8 $ pack exec)-            (maybe "/tmp" (encodeUtf8 . pack) mdir)-            (map encodeUtf8 $ V.toList waconfigArgs)-            (map (encodeUtf8 *** encodeUtf8) env)-            (LogFile.addChunk rlog)-            (const $ return True))-        terminateMonitoredProcess-        $ \mp -> f RunningWebApp-            { rwaProcess = mp-            , rwaPort = waconfigPort-            , rwaEnsureAliveTimeOut = fromMaybe (90 * 1000 * 1000) waconfigEnsureAliveTimeout-            }-  where-    name =-        case aid of-            AIBuiltin -> "__builtin__"-            AINamed x -> x--killWebApp :: (LogMessage -> IO ()) -> RunningWebApp -> IO ()-killWebApp asclog RunningWebApp {..} = do-    status <- printStatus rwaProcess-    asclog $ KillingApp rwaPort status-    terminateMonitoredProcess rwaProcess--ensureAlive :: RunningWebApp -> IO ()-ensureAlive RunningWebApp {..} = do-    didAnswer <- testApp rwaPort-    if didAnswer-        then return ()-        else error $ "ensureAlive failed, this means keter couldn't " <>-                      "detect your app at port " <> show rwaPort <>-                      ", check your app logs detailed errors. " <>-                      " Also make sure your app binds to the PORT environment variable (not YESOD_PORT for example)." -- TODO domain name would be good to add as well-  where-    testApp :: Port -> IO Bool-    testApp port = do-        res <- timeout rwaEnsureAliveTimeOut testApp'-        return $ fromMaybe False res-      where-        testApp' = do-            threadDelay $ 2 * 1000 * 1000-            eres <- try $ connectTo "127.0.0.1" $ show port-            case eres of-                Left (_ :: IOException) -> testApp'-                Right handle -> do-                    hClose handle-                    return True-        connectTo host serv = do-            let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]-                                     , addrSocketType = Stream }-            addrs <- getAddrInfo (Just hints) (Just host) (Just serv)-            firstSuccessful $ map tryToConnect addrs-            where-              tryToConnect addr =-                bracketOnError-                  (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))-                  (close)  -- only done if there's an error-                  (\sock -> do-                    connect sock (addrAddress addr)-                    socketToHandle sock ReadWriteMode-                  )-              firstSuccessful = go Nothing-                where-                  go _ (p:ps) = do-                    r <- tryIO p-                    case r of-                          Right x -> return x-                          Left  e -> go (Just e) ps-                 -- All operations failed, throw error if one exists-                  go Nothing  [] = ioError $ userError $ "connectTo firstSuccessful: empty list"-                  go (Just e) [] = throwIO e-                  tryIO :: IO a -> IO (Either IOException a)-                  tryIO m = catch (liftM Right m) (return . Left)---withBackgroundApps :: AppStartConfig-                   -> AppId-                   -> BundleConfig-                   -> Maybe FilePath-                   -> RotatingLog-                   -> [BackgroundConfig]-                   -> ([RunningBackgroundApp] -> IO a)-                   -> IO a-withBackgroundApps asc aid bconfig mdir rlog configs f =-    bracketedMap alloc f configs-  where-    alloc = launchBackgroundApp asc aid bconfig mdir rlog--launchBackgroundApp :: AppStartConfig-                    -> AppId-                    -> BundleConfig-                    -> Maybe FilePath-                    -> RotatingLog-                    -> BackgroundConfig-                    -> (RunningBackgroundApp -> IO a)-                    -> IO a-launchBackgroundApp AppStartConfig {..} aid BundleConfig {..} mdir rlog BackgroundConfig {..} f = do-    otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins-    forwardedEnv <- getForwardedEnv bgconfigForwardEnv-    let env = Map.toList $ Map.unions-            -- Order matters as in launchWebApp-            [ bgconfigEnvironment-            , forwardedEnv-            , Map.fromList otherEnv-            , kconfigEnvironment ascKeterConfig-            ]-    exec <- canonicalizePath bgconfigExec--    let delay = threadDelay $ fromIntegral $ bgconfigRestartDelaySeconds * 1000 * 1000-    shouldRestart <--        case bgconfigRestartCount of-            UnlimitedRestarts -> return $ do-                delay-                return True-            LimitedRestarts maxCount -> do-                icount <- newIORef 0-                return $ do-                    res <- atomicModifyIORef icount $ \count ->-                        (count + 1, count < maxCount)-                    when res delay-                    return res--    bracketOnError-        (monitorProcess-            (ascLog . OtherMessage . decodeUtf8With lenientDecode)-            ascProcessTracker-            (encodeUtf8 . fst <$> ascSetuid)-            (encodeUtf8 $ pack exec)-            (maybe "/tmp" (encodeUtf8 . pack) mdir)-            (map encodeUtf8 $ V.toList bgconfigArgs)-            (map (encodeUtf8 *** encodeUtf8) env)-            (LogFile.addChunk rlog)-            (const shouldRestart))-        terminateMonitoredProcess-        (f . RunningBackgroundApp)-  where-    name =-        case aid of-            AIBuiltin -> "__builtin__"-            AINamed x -> x--killBackgroundApp :: RunningBackgroundApp -> IO ()-killBackgroundApp RunningBackgroundApp {..} = do-    terminateMonitoredProcess rbaProcess--    {--start :: TempFolder-      -> Maybe (Text, (UserID, GroupID))-      -> ProcessTracker-      -> HostManager-      -> Plugins-      -> RotatingLog-      -> Appname-      -> (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-    Prelude.error "FIXME Keter.App.start"-    chan <- newChan-    return (App $ writeChan chan, rest chan)-  where--    rest chan = forkKIO $ do-        mres <- unpackBundle tf (snd <$> muid) bundle appname-        case mres of-            Left e -> do-                $logEx e-                removeFromList-            Right (dir, config) -> do-                let common = do-                        mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ bconfigStaticHosts config-                        mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ bconfigRedirects config-                case bconfigApp config of-                    Nothing -> do-                        common-                        loop chan dir config Nothing-                    Just appconfig -> do-                        eport <- getPort portman-                        case eport of-                            Left e -> do-                                $logEx e-                                removeFromList-                            Right port -> do-                                eprocess <- runApp port dir appconfig-                                case eprocess of-                                    Left e -> do-                                        $logEx e-                                        removeFromList-                                    Right process -> do-                                        b <- testApp port-                                        if b-                                            then do-                                                addEntry portman (aconfigHost appconfig) $ PEPort port-                                                mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig-                                                common-                                                loop chan dir config $ Just (process, port)-                                            else do-                                                removeFromList-                                                releasePort portman port-                                                void $ liftIO $ terminateMonitoredProcess process--    loop chan dirOld configOld mprocPortOld = do-        command <- readChan chan-        case command of-            Terminate -> do-                removeFromList-                case bconfigApp configOld of-                    Nothing -> return ()-                    Just appconfig -> do-                        removeEntry portman $ aconfigHost appconfig-                        mapM_ (removeEntry portman) $ Set.toList $ aconfigExtraHosts appconfig-                mapM_ (removeEntry portman) $ map shHost $ Set.toList $ bconfigStaticHosts configOld-                mapM_ (removeEntry portman) $ map redFrom $ Set.toList $ bconfigRedirects configOld-                log $ TerminatingApp appname-                terminateOld-            Reload -> do-                mres <- unpackBundle tf (snd <$> muid) bundle appname-                case mres of-                    Left e -> do-                        log $ InvalidBundle bundle e-                        loop chan dirOld configOld mprocPortOld-                    Right (dir, config) -> do-                        eport <- getPort portman-                        case eport of-                            Left e -> $logEx e-                            Right port -> do-                                let common = do-                                        mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ bconfigStaticHosts config-                                        mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ bconfigRedirects config-                                case bconfigApp config of-                                    Nothing -> do-                                        common-                                        loop chan dir config Nothing-                                    Just appconfig -> do-                                        eprocess <- runApp port dir appconfig-                                        mprocess <--                                            case eprocess of-                                                Left _ -> return Nothing-                                                Right process -> do-                                                    b <- testApp port-                                                    return $ if b-                                                        then Just process-                                                        else Nothing-                                        case mprocess of-                                            Just process -> do-                                                addEntry portman (aconfigHost appconfig) $ PEPort port-                                                mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig-                                                common-                                                case bconfigApp configOld of-                                                    Just appconfigOld | aconfigHost appconfig /= aconfigHost appconfigOld ->-                                                        removeEntry portman $ aconfigHost appconfigOld-                                                    _ -> return ()-                                                log $ FinishedReloading appname-                                                terminateOld-                                                loop chan dir config $ Just (process, port)-                                            Nothing -> do-                                                releasePort portman port-                                                case eprocess of-                                                    Left _ -> return ()-                                                    Right process -> void $ liftIO $ terminateMonitoredProcess process-                                                log $ ProcessDidNotStart bundle-                                                loop chan dirOld configOld mprocPortOld-      where-        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--            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--terminate :: App -> IO ()-terminate App {..} = do-    (hosts, apps, backs, mdir, rlog) <- atomically $ do-        hosts <- readTVar appHosts-        apps <- readTVar appRunningWebApps-        backs <- readTVar appBackgroundApps-        mdir <- readTVar appDir-        rlog <- readTVar appRlog--        writeTVar appModTime Nothing-        writeTVar appRunningWebApps []-        writeTVar appBackgroundApps []-        writeTVar appHosts Set.empty-        writeTVar appDir Nothing-        writeTVar appRlog Nothing--        return (hosts, apps, backs, mdir, rlog)--    deactivateApp ascLog ascHostManager appId hosts-    void $ forkIO $ terminateHelper appAsc appId apps backs mdir rlog-    maybe (return ()) LogFile.close rlog-  where-    AppStartConfig {..} = appAsc--terminateHelper :: AppStartConfig-                -> 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-    case mdir of-        Nothing -> return ()-        Just dir -> do-            ascLog $ RemovingOldFolder dir-            res <- try $ removeDirectoryRecursive dir-            case res of-                Left e -> $logEx ascLog e-                Right () -> return ()---- | Get the modification time of the bundle file this app was launched from,--- if relevant.-getTimestamp :: App -> STM (Maybe EpochTime)-getTimestamp = readTVar . appModTime--pluginsGetEnv :: Plugins -> Appname -> Object -> IO [(Text, Text)]-pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps---- | For the forward-env option. From a Set of desired variables, create a--- Map pulled from the system environment.-getForwardedEnv :: Set Text -> IO (Map Text Text)-getForwardedEnv vars = filterEnv <$> getEnvironment-  where-    filterEnv = Map.filterWithKey (\k _ -> Set.member k vars)-              . Map.fromList-              . map (pack *** pack)---    {- FIXME handle static stanzas-    let staticReverse r = do-            HostMan.addEntry hostman (ReverseProxy.reversingHost r)-                $ HostMan.PEReverseProxy-                $ ReverseProxy.RPEntry r manager-    runKIO' $ mapM_ staticReverse (Set.toList kconfigReverseProxy)-    -}--{- FIXME-            rest <--                case Map.lookup appname appMap of-                    Just (app, _time) -> do-                        App.reload app-                        etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)-                        let time = either (P.const 0) id etime-                        return (Map.insert appname (app, time) appMap, return ())-                    Nothing -> do-                        mlogger <- do-                            let dirout = kconfigDir </> "log" </> fromText ("app-" ++ appname)-                                direrr = dirout </> "err"-                            erlog <- liftIO $ LogFile.openRotatingLog-                                (F.encodeString dirout)-                                LogFile.defaultMaxTotal-                            case erlog of-                                Left e -> do-                                    $logEx e-                                    return Nothing-                                Right rlog -> return (Just rlog)-                        let logger = fromMaybe LogFile.dummy mlogger-                        (app, rest) <- App.start-                            tf-                            muid-                            processTracker-                            hostman-                            plugins-                            logger-                            appname-                            bundle-                            (removeApp appname)-                        etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)-                        let time = either (P.const 0) id etime-                        let appMap' = Map.insert appname (app, time) appMap-                        return (appMap', rest)-            rest-            -}

@@ -1,284 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE RecordWildCards   #-}--- | Used for management of applications.-module Keter.AppManager-    ( -- * Types-      AppManager-    , Action (..)-      -- * Actions-    , perform-    , reloadAppList-    , addApp-    , terminateApp-      -- * Initialize-    , initialize-      -- * Show-    , renderApps-    ) where--import           Control.Applicative-import           Control.Concurrent         (forkIO)-import           Control.Concurrent.MVar    (MVar, newMVar, withMVar)-import           Control.Concurrent.STM-import qualified Control.Exception          as E-import           Control.Monad              (void)-import           Data.Foldable              (fold)-import qualified Data.Map                   as Map-import           Data.Maybe                 (catMaybes, mapMaybe)-import qualified Data.Set                   as Set-import           Data.Text                  (pack, unpack)-import qualified Data.Text.Lazy             as LT-import qualified Data.Text.Lazy.Builder     as Builder-import           Data.Traversable.WithIndex (itraverse)-import           Keter.App                  (App, AppStartConfig, showApp)-import qualified Keter.App                  as App-import           Keter.Types-import           Prelude                    hiding (FilePath, log)-import           System.Posix.Files         (getFileStatus, modificationTime)-import           System.Posix.Types         (EpochTime)-import           Text.Printf                (printf)--data AppManager = AppManager-    { apps           :: !(TVar (Map AppId (TVar AppState)))-    , appStartConfig :: !AppStartConfig-    , mutex          :: !(MVar ())-    , log            :: !(LogMessage -> IO ())-    }--data AppState = ASRunning App-              | ASStarting-                    !(Maybe App)-                    !(TVar (Maybe EpochTime))-                    !(TVar (Maybe Action)) -- ^ the next one to try-              | ASTerminated--showAppState :: AppState -> STM Text-showAppState (ASRunning x) = (\x -> "running(" <> x <> ")") <$> showApp x-showAppState (ASStarting mapp tmtime tmaction) = do-  mtime   <- readTVar tmtime-  maction <- readTVar tmaction-  mtext <- traverse showApp mapp-  pure $ pack $ printf "starting app %s, time %s, action %s \n" (unpack $ fold mtext) (show mtime) (show maction)-showAppState ASTerminated = pure "terminated"--renderApps :: AppManager -> STM Text-renderApps mngr = do-  appMap <- readTVar $ apps mngr-  x <- itraverse (\appId tappState -> do-                state <- readTVar tappState-                res <- showAppState state-                pure $ Builder.fromText $ res <> " \n"-               ) appMap-  pure $ LT.toStrict $ Builder.toLazyText $ fold x--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'---- | Reset which apps are running.------ * Any app not listed here that is currently running will be terminated.------ * 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-  where-    toAppName AIBuiltin   = Nothing-    toAppName (AINamed x) = Just x--    getAction currentApps appname = do-        case Map.lookup (AINamed appname) currentApps of-            Nothing -> return freshLaunch-            Just tstate -> do-                state <- readTVar tstate-                case state of-                    ASTerminated -> return freshLaunch-                    ASRunning app ->-                        case Map.lookup appname newApps of-                            Nothing -> return terminate-                            Just (fp, newTimestamp) -> do-                                moldTimestamp <- App.getTimestamp app-                                return $ if moldTimestamp == Just newTimestamp-                                    then Nothing-                                    else reload fp newTimestamp-                    ASStarting _ tmoldTimestamp tmaction ->-                        case Map.lookup appname newApps of-                            Nothing -> do-                                writeTVar tmaction $ Just Terminate-                                return Nothing-                            Just (fp, newTimestamp) -> do-                                moldTimestamp <- readTVar tmoldTimestamp-                                return $ if moldTimestamp == Just newTimestamp-                                    then Nothing-                                    else reload fp newTimestamp-      where-        freshLaunch =-            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)-        {--        case (Map.lookup appname currentApps, Map.lookup appname newApps) of-            (Nothing, Nothing) -> E.assert False Nothing-            (Just _, Nothing) -> Just $ perform am (AINamed appname) Terminate-            (Nothing, Just _) -> Just $ perform am (AINamed appname) (Reload AIBundle)-            -}--    {- FIXME-        actions <- do--            current <- getAllApps appMan-            let apps = Set.toList $ Set.fromList (Map.keys newMap) `Set.union` current-            fmap catMaybes $ forM apps $ \appname -> return $-                case (Set.member appname current, Map.lookup appname newMap) of-                    (False, Nothing) -> Nothing -- should never happen-                    (True, Nothing) -> Just $ terminateApp appname-                    (False, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle-                    (Just (_, oldTime), Just (bundle, newTime))-                        | newTime /= oldTime -> Just $ runKIO' $ addApp bundle-                        | otherwise -> Nothing-        P.sequence_ actions--getAllApps :: AppManager -> IO (Set Appname)-getAllApps AppManager {..} = atomically $ do-    m <- readTVar apps-    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--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'-  where-    noWorker = return ()--    onNotRunning =-        case action of-            Reload input -> do-                tmnext <- newTVar Nothing-                tmtimestamp <- newTVar $-                    case input of-                        AIBundle _fp timestamp -> Just timestamp-                        AIData _               -> Nothing-                tstate <- newTVar $ ASStarting Nothing tmtimestamp tmnext-                modifyTVar apps $ Map.insert aid tstate-                return $ launchWorker am aid tstate tmnext Nothing action-            Terminate -> return noWorker--launchWorker :: AppManager-             -> AppId-             -> TVar AppState-             -> TVar (Maybe Action)-             -> Maybe App-             -> Action-             -> IO ()-launchWorker AppManager {..} appid tstate tmnext mcurrentApp0 action0 = void $ forkIO $ do-    loop mcurrentApp0 action0-  where-    loop mcurrentApp action = do-        mRunningApp <- processAction mcurrentApp action-        mnext <- atomically $ do-            mnext <- readTVar tmnext-            writeTVar tmnext Nothing-            case mnext of-                Nothing ->-                    case mRunningApp of-                        Nothing -> writeTVar tstate ASTerminated-                        Just runningApp -> writeTVar tstate $ ASRunning runningApp-                Just _next -> do-                    tmtimestamp <- newTVar $-                        case action of-                            Reload (AIBundle _fp timestamp) -> Just timestamp-                            Reload (AIData _)               -> Nothing-                            Terminate                       -> Nothing-                    writeTVar tstate $ ASStarting mRunningApp tmtimestamp tmnext-            return mnext-        case mnext of-            Nothing   -> return ()-            Just next -> loop mRunningApp next--    processAction Nothing Terminate = return Nothing-    processAction (Just app) Terminate = do-        log $ Terminating $ show app-        App.terminate app-        return Nothing-    processAction Nothing (Reload input) = do-        log $ ReloadFrom Nothing $ show input-        eres <- E.try $ App.start appStartConfig appid input-        case eres of-            Left e -> do-                log $ ErrorStartingBundle name 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-        case eres of-            Left e -> do-                log $ ErrorStartingBundle name 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)-            Right () -> return $ Just app--    name =-        case appid of-            AIBuiltin -> "<builtin>"-            AINamed x -> x--addApp :: AppManager -> FilePath -> IO ()-addApp appMan bundle = do-    (input, action) <- getInputForBundle bundle-    perform appMan 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-

@@ -1,95 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Keter.Cli-    ( launchCli-    , CliStates(..)-    ) where--import Keter.Types.Common-import Keter.AppManager-import Control.Concurrent (forkFinally)-import qualified Control.Exception as E-import Control.Monad (unless, forever, void, when)-import qualified Data.ByteString as S-import Network.Socket-import Network.Socket.ByteString (recv, sendAll)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Options.Applicative-import Data.Foldable-import GHC.Conc--data Commands = CmdListRunningApps-              | CmdExit--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-commandParser :: Parser Commands-commandParser = hsubparser $-  fold [-  command "exit"-    (info (pure CmdExit)-      (progDesc "List all ports"))-  ,-  command "apps"-      (info (pure CmdListRunningApps)-        (progDesc "Exit the program"))-  ]--resolve :: ServiceName -> IO AddrInfo-resolve port = do-        let hints = defaultHints {-                addrFlags = [AI_PASSIVE]-              , addrSocketType = Stream-              }-        addr:_ <- getAddrInfo (Just hints) Nothing (Just port)-        return addr--open :: AddrInfo -> IO Socket-open addr = do-    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)-    setSocketOption sock ReuseAddr 1-    -- If the prefork technique is not used,-    -- set CloseOnExec for the security reasons.-    withFdSocket sock $ setCloseOnExecIfNeeded-    bind sock (addrAddress addr)-    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)--listRunningApps :: CliStates -> Socket -> IO ()-listRunningApps states conn = do-  txt <- atomically $ renderApps $ csAppManager states-  sendAll conn $ T.encodeUtf8 txt <> "\n"--talk :: CliStates -> Socket -> IO ()-talk states conn = do-    msg <- 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))-        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"-            Failure failure        ->-              True <$ sendAll conn (T.encodeUtf8 (T.pack $ fst $ renderFailure failure "") <> "\n")-          when isLoop $ talk states conn

@@ -1,181 +0,0 @@-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE ViewPatterns        #-}
-module Keter.HostManager
-    ( -- * Types
-      HostManager
-    , Reservations
-      -- * Actions
-    , reserveHosts
-    , forgetReservations
-    , activateApp
-    , deactivateApp
-    , reactivateApp
-    , lookupAction
-      -- * Initialize
-    , start
-    ) where
-
-import           Control.Applicative
-import           Control.Exception   (assert, throwIO)
-import qualified Data.CaseInsensitive as CI
-import           Data.Either         (partitionEithers)
-import           Data.IORef
-import qualified Data.Map            as Map
-import qualified Data.Set            as Set
-import           Data.Text.Encoding  (encodeUtf8)
-import           Keter.Types
-import           Keter.LabelMap      (LabelMap)
-import qualified Keter.LabelMap      as LabelMap
-import           Prelude             hiding (log)
-import qualified Network.TLS as TLS
-
-type HMState = LabelMap HostValue
-
-data HostValue = HVActive   !AppId !ProxyAction !TLS.Credentials
-               | HVReserved !AppId
-
-newtype HostManager = HostManager (IORef HMState)
-
-type Reservations = Set.Set Host
-
-start :: IO HostManager
-start = HostManager <$> newIORef LabelMap.empty
-
--- | Reserve the given hosts so that no other application may use them. Does
--- not yet enable any action. The semantics are:
---
--- 1. If a requested host is currently actively used or by an app of the same name, it is
---    considered reserved.
---
--- 2. If a requested host is currently reserved by an app of the same name, it
---    is considered an error in calling this API. Only one app reservation can
---    happen at a time.
---
--- 3. If any requested host is currently used or reserved by an app with a
---    different name, then those values are returned as @Left@.
---
--- 4. Otherwise, the hosts which were reserved are returned as @Right@. This
---    does /not/ include previously active hosts.
-reserveHosts :: (LogMessage -> IO ())
-             -> HostManager
-             -> 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))
-  where
-    checkHost entries0 host =
-        case LabelMap.labelAssigned hostBS entries0 of
-            False -> Right $ Set.singleton host
-            True  -> 
-              case LabelMap.lookup hostBS entries0 of
-                Nothing -> Right $ Set.singleton host
-                Just (HVReserved aid') -> assert (aid /= aid')
-                                        $ Left (host, aid')
-                Just (HVActive aid' _ _)
-                    | aid == aid' -> Right Set.empty
-                    | otherwise   -> Left (host, aid')
-      where hostBS = encodeUtf8 $ CI.original host
-
-    hvres = HVReserved aid
-    reserve host es =
-        assert (not $ LabelMap.labelAssigned hostBS es) $ LabelMap.insert hostBS hvres es
-      where
-        hostBS = encodeUtf8 $ CI.original host
-
--- | Forget previously made reservations.
-forgetReservations :: (LogMessage -> IO ())
-                   -> HostManager
-                   -> AppId
-                   -> Reservations
-                   -> IO ()
-forgetReservations log (HostManager mstate) app hosts = do
-    log $ ForgetingReservations app hosts
-    atomicModifyIORef mstate $ \state0 ->
-        (Set.foldr forget state0 hosts, ())
-  where
-    forget host state =
-        assert isReservedByMe $ LabelMap.delete hostBS state
-      where
-        hostBS = encodeUtf8 $ CI.original host
-        isReservedByMe = LabelMap.labelAssigned hostBS state &&
-            case LabelMap.lookup hostBS state of
-                Nothing -> False
-                Just (HVReserved app') -> app == app'
-                Just HVActive{} -> False
-
--- | Activate a new app. Note that you /must/ first reserve the hostnames you'll be using.
-activateApp :: (LogMessage -> IO ())
-            -> HostManager
-            -> AppId
-            -> Map.Map Host (ProxyAction, TLS.Credentials)
-            -> IO ()
-activateApp log (HostManager mstate) app actions = do
-    log $ ActivatingApp app $ Map.keysSet actions
-    atomicModifyIORef mstate $ \state0 ->
-        (activateHelper app state0 actions, ())
-
-activateHelper :: AppId -> HMState -> Map Host (ProxyAction, TLS.Credentials) -> HMState
-activateHelper app =
-    Map.foldrWithKey activate
-  where
-    activate host (action, cr) state =
-        assert isOwnedByMe $ LabelMap.insert hostBS (HVActive app action cr) state
-      where
-        hostBS = encodeUtf8 $ CI.original host
-        isOwnedByMe = LabelMap.labelAssigned hostBS state &&
-            case LabelMap.lookup hostBS state of
-                Nothing -> False
-                Just (HVReserved app') -> app == app'
-                Just (HVActive app' _ _) -> app == app'
-
-deactivateApp :: (LogMessage -> IO ())
-              -> HostManager
-              -> AppId
-              -> Set Host
-              -> IO ()
-deactivateApp log (HostManager mstate) app hosts = do
-    log $ DeactivatingApp app hosts
-    atomicModifyIORef mstate $ \state0 ->
-        (deactivateHelper app state0 hosts, ())
-
-deactivateHelper :: AppId -> HMState -> Set Host -> HMState
-deactivateHelper app =
-    Set.foldr deactivate
-  where
-    deactivate host state =
-        assert isOwnedByMe $ LabelMap.delete hostBS state
-      where
-        hostBS = encodeUtf8 $ CI.original host
-        isOwnedByMe = LabelMap.labelAssigned hostBS state &&
-            case LabelMap.lookup hostBS state of
-                Nothing -> False
-                Just (HVActive app' _ _) -> app == app'
-                Just HVReserved {} -> False
-
-reactivateApp :: (LogMessage -> IO ())
-              -> HostManager
-              -> 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 ->
-        (activateHelper app (deactivateHelper app state0 hosts) actions, ())
-
-lookupAction :: HostManager
-             -> HostBS
-             -> IO (Maybe (ProxyAction, TLS.Credentials))
-lookupAction (HostManager mstate) host = do
-    state <- readIORef mstate
-    return $ case LabelMap.lookup (CI.original host) state of
-        Nothing -> Nothing
-        Just (HVActive _ action cert) -> Just (action, cert)
-        Just (HVReserved _) -> Nothing

@@ -1,315 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}-module Keter.LabelMap-    ( -- * Types-      LabelMap-      -- * Helper functions-    , insert-    , delete-    , lookup-    , labelAssigned-    , empty-    ) where--import Prelude hiding (lookup)-import Data.Maybe (isJust)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.ByteString.Char8 as BS-import Data.ByteString (ByteString)-import qualified Data.CaseInsensitive as CI-import Data.CaseInsensitive (CI)--type LabelTree a = Map (CI ByteString) (LabelEntry a)---- | A data structure for storing a hierarchical set of domain labels--- from TLD down, supporting wildcards.------ Data structure is mutually recursive with 'LabelEntry', and each level--- of the tree supports a static assignment for a hostname such as:------ >  example.com------ Or a wildcard assignment for a hostname such as:------ >  *.example.com------ Or a wildcard assignment with a set of teptions, for example:------ >  *.example.com--- >  admin.example.com------ And lastly, empty labels are supported so that, of course, an assignment--- for example.com does not necessarily have any subdomains available. As an example--- suppose we have the following assigned domains:------ >          example.com--- >      foo.example.com--- >    *.bar.example.com--- >    *.qux.example.com--- >  baz.qux.example.com------ This will resolve to the following value, with some loose pseudocode notation.------ >  Static (map)--- >    'com' -> Unassigned Static (map)--- >      'example' -> Assigned a (map)--- >         'foo'  -> Assigned a EmptyLabelMap--- >         'bar'  -> Unassigned (Wildcard (Assigned a EmptyLabelMap)--- >         'qux'  -> Unassigned (WildcardExcept (Assigned a (map)))--- >           'baz' -> Assigned a EmptyLabelMap------ Note that the hostname "bar.example.com" is unassigned, only the wildcard was set.----data LabelMap a = EmptyLabelMap-                | Static         !(LabelTree a)-                | Wildcard       !(LabelEntry a)-                | WildcardExcept !(LabelEntry a) !(LabelTree a)-    deriving (Show, Eq)---- | Indicates whether a given label in the-data LabelEntry a = Assigned   !a !(LabelMap a)-                  | Unassigned    !(LabelMap a)-                  deriving Eq--instance Show (LabelEntry a) where-    show (Assigned _ m) = "Assigned _ (" ++ show m ++ ")"-    show (Unassigned m) = "Unassigned (" ++ show m ++ ")"--hostToLabels :: ByteString -> [ByteString]-hostToLabels h-  | BS.null h        = []-  | BS.last h == '.' = drop 1 labels-  | otherwise        = labels-  where labels = reverse . BS.split '.' $ h--lemap :: (LabelMap a -> LabelMap a) -> LabelEntry a -> LabelEntry a-lemap f (Assigned e m) = Assigned e (f m)-lemap f (Unassigned m) = Unassigned (f m)--labelEntryMap :: LabelEntry a -> LabelMap a-labelEntryMap (Assigned _ m) = m-labelEntryMap (Unassigned m) = m--getPortEntry :: LabelEntry a -> Maybe a-getPortEntry (Assigned e _) = Just e-getPortEntry (Unassigned _) = Nothing--insert :: ByteString -> a -> LabelMap a -> LabelMap a-insert h e m = insertTree (hostToLabels h) e m---insert h e m = trace---       ( "Inserting hostname " ++ (show h) ++ "\n"---       ++"  into tree        " ++ (show m) ++ "\n"---       ++"  with result      " ++ (show result)---       )---       result---    where result = insertTree (hostToLabels h) e m--insertTree :: [ByteString] -> a -> LabelMap a -> LabelMap a-insertTree []    _ _ = error "Cannot assign empty label in hostname."--insertTree ["*"] e EmptyLabelMap = Wildcard (Assigned e EmptyLabelMap)-insertTree [l]   e EmptyLabelMap = Static (Map.insert (CI.mk l) (Assigned e EmptyLabelMap) Map.empty)--insertTree ["*"] e (Static t) = WildcardExcept (Assigned e EmptyLabelMap) t-insertTree [l']   e (Static t) =-    case Map.lookup l t of-        Nothing  -> Static (Map.insert l (Assigned e EmptyLabelMap) t)-        Just le  -> Static (Map.insert l (Assigned e (labelEntryMap le)) t)-  where-    l = CI.mk l'--insertTree ["*"] e (Wildcard w) = Wildcard (Assigned e (labelEntryMap w))-insertTree [l]   e (Wildcard w) = WildcardExcept w (Map.insert (CI.mk l) (Assigned e EmptyLabelMap) Map.empty)--insertTree ["*"] e (WildcardExcept w t) = WildcardExcept (Assigned e (labelEntryMap w)) t-insertTree [l']   e (WildcardExcept w t) =-    case Map.lookup l t of-        Nothing -> WildcardExcept w (Map.insert l (Assigned e EmptyLabelMap) t)-        Just le -> WildcardExcept w (Map.insert l (Assigned e (labelEntryMap le)) t)-  where-    l = CI.mk l'--insertTree ("*":ls) e EmptyLabelMap = Wildcard (Unassigned (insertTree ls e EmptyLabelMap))-insertTree (l:ls)   e EmptyLabelMap = Static (Map.insert (CI.mk l) (Unassigned $ insertTree ls e EmptyLabelMap) Map.empty)--insertTree ("*":ls) e (Static t) = WildcardExcept (Unassigned (insertTree ls e EmptyLabelMap)) t-insertTree (l':ls)   e (Static t) =-    case Map.lookup l t of-        Nothing -> Static (Map.insert l (Unassigned (insertTree ls e EmptyLabelMap)) t)-        Just le -> Static (Map.insert l (lemap (insertTree ls e) le) t)-  where-    l = CI.mk l'--insertTree ("*":ls) e (Wildcard w) = Wildcard (lemap (insertTree ls e) w)-insertTree (l:ls)   e (Wildcard w) = WildcardExcept w (Map.insert (CI.mk l) (Assigned e (insertTree ls e EmptyLabelMap)) Map.empty)--insertTree ("*":ls) e (WildcardExcept w t) = WildcardExcept (lemap (insertTree ls e) w) t-insertTree (l:ls)   e (WildcardExcept w t) =-    case Map.lookup l' t of-        Nothing -> WildcardExcept w (Map.insert l' (Unassigned (insertTree ls e EmptyLabelMap)) t)-        Just le -> WildcardExcept w (Map.insert l' (lemap (insertTree ls e) le) t)-  where-    l' = CI.mk l--cleanup :: LabelMap a -> LabelMap a-cleanup EmptyLabelMap = EmptyLabelMap-cleanup m@(Static t) =-    case Map.null (Map.filter p t) of-        True  -> EmptyLabelMap-        False -> m-    where-        p (Unassigned EmptyLabelMap) = False-        p _ = True--cleanup m@(Wildcard w) =-    case w of-        Unassigned EmptyLabelMap -> EmptyLabelMap-        _ -> m--cleanup m@(WildcardExcept w t) =-    case (w, Map.null t) of-        (Unassigned EmptyLabelMap, True)  -> EmptyLabelMap-        (Unassigned EmptyLabelMap, False) -> Static t-        (_,                        True)  -> Wildcard w-        (_,                        False) -> m--delete :: ByteString -> LabelMap a -> LabelMap a-delete h m = deleteTree (hostToLabels h) m---delete h m = trace---       ( "Deleting hostname  " ++ (show h) ++ "\n"---       ++"  into tree        " ++ (show m) ++ "\n"---       ++"  with result      " ++ (show result)---       )---       result---    where result = deleteTree (hostToLabels h) m--deleteTree :: [ByteString] -> LabelMap a -> LabelMap a-deleteTree [] _ = error "Cannot assign empty label in hostname."--deleteTree _ EmptyLabelMap = EmptyLabelMap--deleteTree ["*"] (Static t) = Static t-deleteTree [l]   (Static t) = cleanup $ Static m-   where-    m = case l' `Map.lookup` t of-      Just (Assigned _ EmptyLabelMap) -> Map.delete l' t-      Just (Assigned _ b) -> Map.insert l' (Unassigned b) (Map.delete l' t)-      _ -> t-    l' = CI.mk l--deleteTree ["*"] (Wildcard w) = cleanup $ Wildcard (Unassigned (labelEntryMap w))-deleteTree [_] (Wildcard w) = Wildcard w--deleteTree ["*"] (WildcardExcept w t) = cleanup $ WildcardExcept (Unassigned (labelEntryMap w)) t-deleteTree [l] (WildcardExcept w t) = cleanup $ WildcardExcept w (Map.delete (CI.mk l) t)--deleteTree ("*":_) (Static t) = Static t-deleteTree (l:ls)  (Static t) = cleanup $-    case Map.lookup l' t of-        Nothing -> Static t-        Just le -> Static (Map.insert l' (lemap (deleteTree ls) le) t)-  where-    l' = CI.mk l--deleteTree ("*":ls) (Wildcard w) = cleanup $ Wildcard (lemap (deleteTree ls) w)-deleteTree (_:_)    (Wildcard w) = Wildcard w--deleteTree ("*":ls) (WildcardExcept w t) = cleanup $ WildcardExcept (lemap (deleteTree ls) w) t-deleteTree (l:ls) (WildcardExcept w t) = cleanup $-    case Map.lookup l' t of-        Nothing            -> WildcardExcept w t-        Just le            -> WildcardExcept w (Map.insert l' (lemap (deleteTree ls) le) t)-  where-    l' = CI.mk l--lookup :: ByteString -> LabelMap a -> Maybe a-lookup h m = lookupTree (hostToLabels h) m---lookup h m = trace---       ( "Looking up hostname  " ++ (show h) ++ "\n"---       ++"  in tree            " ++ (show m) ++ "\n"---       ++"  and found entry?   " ++ (show $ isJust result)---       )---       result---    where result = (lookupTree (hostToLabels h) m)--lookupTree :: [ByteString] -> LabelMap a -> Maybe a-lookupTree [] _ = Nothing--lookupTree _ EmptyLabelMap = Nothing--lookupTree [l] (Static t)   = Map.lookup (CI.mk l) t >>= getPortEntry-lookupTree [_] (Wildcard w) = getPortEntry $ w-lookupTree [l] (WildcardExcept w t) =-    case Map.lookup (CI.mk l) t >>= getPortEntry of-        Just e  -> Just e-        Nothing -> getPortEntry w--lookupTree (l:ls) (Static t) =-    case Map.lookup (CI.mk l) t of-        Just le -> lookupTree ls $ labelEntryMap le-        Nothing -> Nothing-lookupTree (_:ls) (Wildcard w) = lookupTree ls $ labelEntryMap w-lookupTree (l:ls) (WildcardExcept w t) =-    case Map.lookup (CI.mk l) t of-        Just le ->-            case lookupTree ls $ labelEntryMap le of-                Just  e -> Just e-                Nothing -> lookupTree ls $ labelEntryMap w-        Nothing -> lookupTree ls $ labelEntryMap w---- This function is similar to lookup but it determines strictly--- whether or not a record to be inserted would override an existing--- entry exactly. i.e.: When inserting *.example.com, this function--- will return true for precisely *.example.com, but not foo.example.com.------ This is so that different keter applications may establish ownership--- over different subdomains, including exceptions to a wildcard.------ This function *does not* test whether or not a given input would--- resolve to an existing host. In the above example, given only an--- inserted *.example.com, foo.example.com would route to the wildcard.--- Even so, labelAssigned will return false, foo.example.com has not--- been explicitly assigned.-labelAssigned :: ByteString -> LabelMap a -> Bool-labelAssigned h m = memberTree (hostToLabels h) m---labelAssigned h m = trace---       ( "Checking label assignment for " ++ (show h) ++ "\n"---       ++"  in tree            " ++ (show m) ++ "\n"---       ++"  and found?         " ++ (show result)---       )---       result---    where result = memberTree (hostToLabels h) m--memberTree :: [ByteString] -> LabelMap a -> Bool-memberTree [] _ = False--memberTree ["*"] (Static _)   = False-memberTree [l]   (Static t)   = isJust $ Map.lookup (CI.mk l) t >>= getPortEntry--memberTree ["*"] (Wildcard _) = True-memberTree [_]   (Wildcard _) = False--memberTree ["*"] (WildcardExcept w _) = isJust $ getPortEntry w-memberTree [l]   (WildcardExcept _ t) = isJust $ Map.lookup (CI.mk l) t >>= getPortEntry--memberTree ("*":_) (Static _) = False-memberTree (l:ls)  (Static t) =-    case Map.lookup (CI.mk l) t of-        Just le -> memberTree ls $ labelEntryMap le-        Nothing -> False--memberTree ("*":ls) (Wildcard w) = memberTree ls $ labelEntryMap w-memberTree (_:_)    (Wildcard _) = False--memberTree ("*":ls) (WildcardExcept w _) = memberTree ls $ labelEntryMap w-memberTree (l:ls)   (WildcardExcept _ t) =-    case Map.lookup (CI.mk l) t of-        Just le -> memberTree ls $ labelEntryMap le-        Nothing -> False--memberTree _ EmptyLabelMap = False--empty :: LabelMap a-empty = EmptyLabelMap

@@ -1,236 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}--module Keter.Main-    ( keter-    ) where--import qualified Codec.Archive.TempTarball as TempFolder-import           Control.Concurrent.Async  (waitAny, withAsync)-import           Control.Monad             (unless)-import qualified Data.Conduit.LogFile      as LogFile-import           Data.Monoid               (mempty)-import           Data.String               (fromString)-import qualified Data.Vector               as V-import           Keter.App                 (AppStartConfig (..))-import qualified Keter.AppManager          as AppMan-import qualified Keter.HostManager         as HostMan-import qualified Keter.PortPool            as PortPool-import qualified Keter.Proxy               as Proxy-import           Keter.Types-import           System.Posix.Files        (getFileStatus, modificationTime)-import           System.Posix.Signals      (Handler (Catch), installHandler,-                                            sigHUP)--import           Control.Applicative       ((<$>))-import           Control.Exception         (throwIO, try)-import           Control.Monad             (forM)-import           Control.Monad             (void, when)-import           Data.Conduit.Process.Unix (initProcessTracker)-import           Data.Default              (def)-import qualified Data.Map                  as Map-import qualified Data.Text                 as T-import           Data.Text.Encoding        (encodeUtf8)-import qualified Data.Text.Read-import           Data.Time                 (getCurrentTime)-import           Data.Yaml.FilePath-import           Prelude                   hiding (FilePath, log)-import           System.Directory          (createDirectoryIfMissing,-                                            createDirectoryIfMissing,-                                            doesDirectoryExist, doesFileExist,-                                            getDirectoryContents)-import           System.FilePath           (takeExtension, (</>))-import qualified System.FSNotify           as FSN-import           System.Posix.User         (getUserEntryForID,-                                            getUserEntryForName, userGroupID,-                                            userID, userName)-#ifdef SYSTEM_FILEPATH-import qualified Filesystem.Path as FP (FilePath)-import           Filesystem.Path.CurrentOS (encodeString)-#endif-import Keter.Cli--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---- | Load up Keter config.-withConfig :: FilePath-           -> (KeterConfig -> IO a)-           -> IO a-withConfig input f = do-    exists <- doesFileExist input-    config <--        if exists-            then do-                eres <- decodeFileRelative input-                case eres of-                    Left e -> throwIO $ InvalidKeterConfigFile input e-                    Right x -> return x-            else return def { 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--    f config $ \ml -> do-        now <- getCurrentTime-        let bs = encodeUtf8 $ T.pack $ concat-                [ take 22 $ show now-                , ": "-                , show ml-                , "\n"-                ]-        LogFile.addChunk mainlog 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-    muid <--        case kconfigSetuid of-            Nothing -> return Nothing-            Just t -> do-                x <- try $-                    case Data.Text.Read.decimal t of-                        Right (i, "") -> getUserEntryForID i-                        _ -> getUserEntryForName $ T.unpack t-                case x of-                    Left (_ :: SomeException) -> error $ "Invalid user ID: " ++ T.unpack t-                    Right ue -> return $ Just (T.pack $ userName ue, (userID ue, userGroupID ue))--    let appStartConfig = AppStartConfig-            { ascTempFolder = tf-            , ascSetuid = muid-            , ascProcessTracker = processTracker-            , ascHostManager = hostman-            , ascPortPool = portpool-            , ascPlugins = plugins-            , ascLog = log-            , ascKeterConfig = kc-            }-    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--    unless (V.null kconfigBuiltinStanzas) $ AppMan.perform-        appMan-        AIBuiltin-        (AppMan.Reload $ AIData $ BundleConfig kconfigBuiltinStanzas mempty)-  where-    incoming = getIncoming kc--getIncoming :: KeterConfig -> FilePath-getIncoming kc = kconfigDir kc </> "incoming"--isKeter :: FilePath -> Bool-isKeter fp = takeExtension fp == ".keter"--startWatching :: KeterConfig -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO ()-startWatching kc appMan log = do-    -- 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----- compatibility with older versions of fsnotify which used--- 'Filesystem.Path'-#ifdef SYSTEM_FILEPATH-fromFilePath :: FP.FilePath -> String-fromFilePath = encodeString-#else-fromFilePath :: forall a. a -> a-fromFilePath = id-#endif--listDirectoryTree :: FilePath -> IO [FilePath]-listDirectoryTree fp = do-       dir <- getDirectoryContents fp-       concat <$> mapM (\fpRel -> do-          let fp1 = fp </> fpRel-          isDir <- doesDirectoryExist fp1-          if isDir-           then-             listDirectoryTree fp1-           else-             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--runAndBlock :: NonEmptyVector a-            -> (a -> IO ())-            -> IO ()-runAndBlock (NonEmptyVector x0 v) f =-    loop l0 []-  where-    l0 = x0 : V.toList v--    loop (x:xs) asyncs = withAsync (f x) $ \async -> loop xs $ async : asyncs-    -- Once we have all of our asyncs, we wait for /any/ of them to exit. If-    -- any listener thread exits, we kill the whole process.-    loop [] asyncs = void $ waitAny asyncs

@@ -1,198 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-module Keter.Plugin.Postgres-    ( -- * Settings-      Settings-    , setupDBInfo-      -- * Functions-    , load-    ) where--import           Control.Applicative       ((<$>), (<*>), pure)-import           Data.Aeson.KeyHelper      as AK (lookup)-import           Control.Concurrent        (forkIO)-import           Control.Concurrent.Chan-import           Control.Concurrent.MVar-import           Control.Exception         (throwIO, try)-import           Control.Monad             (forever, mzero, replicateM, void)-import           Control.Monad.Trans.Class (lift)-import qualified Control.Monad.Trans.State as S-import qualified Data.Char                 as C-import           Data.Default-import qualified Data.Map                  as Map-import           Data.Maybe                (fromMaybe)-import           Data.Monoid               ((<>))-import qualified Data.Text                 as T-import qualified Data.Text.Lazy            as TL-import           Data.Text.Lazy.Builder    (fromText, toLazyText)-import qualified Data.Vector               as V-import           Data.Yaml-import           Keter.Types-import           Prelude                   hiding (FilePath)-import           System.Directory          (createDirectoryIfMissing,-                                            doesFileExist, renameFile)-import           System.FilePath           (takeDirectory, (<.>))-import           System.Process            (readProcess)-import qualified System.Random             as R--data Settings = Settings-    { setupDBInfo :: DBInfo -> IO ()-      -- ^ How to create the given user/database. Default: uses the @psql@-      -- command line tool and @sudo -u postgres@.-    }--instance Default Settings where-    def = Settings-        { setupDBInfo = \DBInfo{..} -> do-            let sql = toLazyText $-                    "CREATE USER "         <> fromText dbiUser <>-                    " PASSWORD '"          <> fromText dbiPass <>-                    "';\nCREATE DATABASE " <> fromText dbiName <>-                    " OWNER "              <> fromText dbiUser <>-                    ";"-                (cmd, args) -                    | (  dbServer dbiServer == "localhost" -                      || dbServer dbiServer == "127.0.0.1") = -                        ("sudo", ["-u", "postgres", "psql"])-                    | otherwise = -                        ("psql",-                        [ "-h", (T.unpack $ dbServer dbiServer)-                        , "-p", (show $ dbPort dbiServer)-                        , "-U", "postgres"])-            _ <- readProcess cmd args $ TL.unpack sql-            return ()-        }---- | Information on an individual PostgreSQL database.-data DBInfo = DBInfo-    { dbiName   :: Text-    , dbiUser   :: Text-    , dbiPass   :: Text-    , dbiServer :: DBServerInfo-    }-    deriving Show--data DBServerInfo = DBServerInfo-    { dbServer :: Text-    , dbPort   :: Int-    }-    deriving Show--randomDBI :: DBServerInfo -> R.StdGen -> (DBInfo, R.StdGen)-randomDBI dbsi =-    S.runState (DBInfo <$> rt <*> rt <*> rt <*> (pure dbsi)) -  where-    rt = T.pack <$> replicateM 10 (S.state $ R.randomR ('a', 'z'))--instance ToJSON DBInfo where-    toJSON (DBInfo n u p (DBServerInfo server port)) = object-        [ "name"   .= n-        , "user"   .= u-        , "pass"   .= p-        , "server" .= server-        , "port"   .= port-        ]--instance FromJSON DBInfo where-    parseJSON (Object o) = DBInfo-        <$> o .: "name"-        <*> o .: "user"-        <*> o .: "pass"-        <*> (DBServerInfo-            <$> o .:? "server" .!= "localhost"-            <*> o .:? "port"   .!= 5432)-    parseJSON _ = mzero--instance FromJSON DBServerInfo where-    parseJSON (Object o) = DBServerInfo-        <$> o .: "server"-        <*> o .: "port"-    parseJSON _ = mzero-    -instance Default DBServerInfo where-    def = DBServerInfo "localhost" 5432--data Command = GetConfig Appname DBServerInfo (Either SomeException DBInfo -> IO ())---- | Load a set of existing connections from a config file. If the file does--- not exist, it will be created. Any newly created databases will--- automatically be saved to this file.-load :: Settings -> FilePath -> IO Plugin-load Settings{..} fp = do-    createDirectoryIfMissing True $ takeDirectory fp-    e <- doesFileExist fp-    edb <- if e-        then decodeFileEither fp-        else return $ Right Map.empty-    case edb of-        Left ex -> throwIO ex-        Right db -> go db-  where-    go db0 = do-        chan <- newChan-        g0 <- R.newStdGen-        -- FIXME stop using the worker thread approach?-        void $ forkIO $ flip S.evalStateT (db0, g0) $ forever $ loop chan-        return Plugin-            { pluginGetEnv = \appname o ->-                case AK.lookup "postgres" o of-                    Just (Array v) -> do-                        let dbServer = fromMaybe def . parseMaybe parseJSON $ V.head v-                        doenv chan appname dbServer-                    Just (Bool True) -> do-                        doenv chan appname def-                    _ -> return []-            }-      where doenv chan appname dbs = do-            x <- newEmptyMVar-            writeChan chan $ GetConfig appname dbs $ putMVar x-            edbi <- takeMVar x-            edbiToEnv edbi-                    -    tmpfp = fp <.> "tmp"--    loop chan = do-        GetConfig appname dbServer f <- lift $ readChan chan-        (db, g) <- S.get-        dbi <--            case Map.lookup appname db of-                Just dbi -> return $ Right dbi-                Nothing -> do-                    let (dbi', g') = randomDBI dbServer g-                    let dbi = dbi'-                            { dbiName = sanitize appname <> dbiName dbi'-                            , dbiUser = sanitize appname <> dbiUser dbi'-                            }-                    ex <- lift $ try $ setupDBInfo dbi-                    case ex of-                        Left e -> return $ Left e-                        Right () -> do-                            let db' = Map.insert appname dbi db-                            ey <- lift $ try $ do-                                encodeFile tmpfp db'-                                renameFile tmpfp fp-                            case ey of-                                Left e -> return $ Left e-                                Right () -> do-                                    S.put (db', g')-                                    return $ Right dbi-        lift $ f dbi--    sanitize = T.map sanitize'-    sanitize' c-        | 'A' <= c && c <= 'Z' = C.toLower c-        | 'a' <= c && c <= 'z' = c-        | '0' <= c && c <= '9' = c-        | otherwise = '_'--edbiToEnv :: Either SomeException DBInfo-          -> IO [(Text, Text)]-edbiToEnv (Left e) = throwIO e-edbiToEnv (Right dbi) = return-    [ ("PGHOST", dbServer $ dbiServer dbi)-    , ("PGPORT", T.pack . show . dbPort $ dbiServer dbi)-    , ("PGUSER", dbiUser dbi)-    , ("PGPASS", dbiPass dbi)-    , ("PGDATABASE", dbiName dbi)-    ]-

@@ -1,86 +0,0 @@-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}--- | Manages a pool of available ports and allocates them.-module Keter.PortPool-    ( -- * Types-      PortPool-      -- * Actions-    , getPort-    , releasePort-      -- * Initialize-    , start-    ) where--import           Control.Applicative     ((<$>))-import           Control.Concurrent.MVar-import           Control.Exception-import           Keter.Types-import           Network.Socket-import           Prelude                 hiding (log)--data PPState = PPState-    { ppAvail    :: ![Port]-    , ppRecycled :: !([Port] -> [Port])-    }--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-  where-    loop :: PPState -> IO (PPState, Either SomeException Port)-    loop PPState {..} =-        case ppAvail of-            p:ps -> do-                let next = PPState ps ppRecycled-                res <- try $ listenOn $ show p-                case res of-                    Left (_ :: SomeException) -> do-                        log $ RemovingPort p-                        loop next-                    Right socket' -> do-                        res' <- try $ close socket'-                        case res' of-                            Left e -> do-                                $logEx log e-                                log $ RemovingPort p-                                loop next-                            Right () -> return (next, Right p)-            [] ->-                case ppRecycled [] of-                    [] -> return (PPState [] id, Left $ toException NoPortsAvailable)-                    ps -> loop $ PPState ps id--    listenOn port = do-        let hints = defaultHints {-                addrFlags = [AI_PASSIVE]-              , addrSocketType = Stream-              }-        addr:_ <- getAddrInfo (Just hints) Nothing (Just port)-        bracketOnError-             (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))-             (close)-             (\sock -> do-                 setSocketOption sock ReuseAddr 1-                 bind sock (addrAddress addr)-                 listen sock maxListenQueue-                 return sock-             )---- | Return a port to the recycled collection of the pool.  Note that recycling--- puts the new ports at the end of the queue (FIFO), so that if an application--- holds onto the port longer than expected, there should be no issues.-releasePort :: PortPool -> Port -> IO ()-releasePort (PortPool mstate) p =-    modifyMVar_ mstate $ \(PPState avail recycled) -> return $ PPState avail $ recycled . (p:)--start :: PortSettings -> IO PortPool-start PortSettings{..} =-    PortPool <$> newMVar freshState-  where-    freshState = PPState portRange id

@@ -1,320 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TupleSections   #-}-{-# LANGUAGE CPP #-}--- | A light-weight, minimalistic reverse HTTP proxy.-module Keter.Proxy-    ( reverseProxy-    , makeSettings-    , ProxySettings(..)-    , TLSConfig (..)-    ) where--import qualified Network.HTTP.Conduit      as HTTP-import qualified Data.CaseInsensitive      as CI-import qualified Keter.HostManager         as HostMan-import           Blaze.ByteString.Builder          (copyByteString, toByteString)-import           Blaze.ByteString.Builder.Html.Word(fromHtmlEscapedByteString)-import           Control.Applicative               ((<$>), (<|>))-import           Control.Monad.IO.Class            (liftIO)-import qualified Data.ByteString                   as S-import qualified Data.ByteString.Char8             as S8-import qualified Data.CaseInsensitive              as CI-#if MIN_VERSION_http_reverse_proxy(0,6,0)-import           Network.Wai.Middleware.Gzip       (def)-#else-import           Data.Default                      (Default (..))-#endif-import           Data.Monoid                       (mappend, mempty)-import           Data.Text.Encoding                (decodeUtf8With, encodeUtf8)-import           Data.Text.Encoding.Error          (lenientDecode)-import qualified Data.Vector                       as V-import           Keter.Types-import           Keter.Types.Middleware-import           Network.HTTP.Conduit              (Manager)--#if MIN_VERSION_http_reverse_proxy(0,4,2)-import           Network.HTTP.ReverseProxy         (defaultLocalWaiProxySettings)-#endif--#if MIN_VERSION_http_reverse_proxy(0,6,0)-import           Network.HTTP.ReverseProxy         (defaultWaiProxySettings)-#endif--import           Network.HTTP.ReverseProxy         (ProxyDest (ProxyDest),-                                                    SetIpHeader (..),-                                                    WaiProxyResponse (..),-                                                    LocalWaiProxySettings,-                                                    setLpsTimeBound,-                                                    waiProxyToSettings,-                                                    wpsSetIpHeader,-                                                    wpsOnExc,-                                                    wpsGetDest)-import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite-import           Network.HTTP.Types                (mkStatus, status200,-                                                    status301, status302,-                                                    status303, status307,-                                                    status404, status502)-import qualified Network.Wai                       as Wai-import           Network.Wai.Application.Static    (defaultFileServerSettings,-                                                    ssListing, staticApp)-import qualified Network.Wai.Handler.Warp          as Warp-import qualified Network.Wai.Handler.WarpTLS       as WarpTLS-import qualified Network.TLS.SessionManager        as TLSSession-import           Network.Wai.Middleware.Gzip       (gzip, GzipSettings(..), GzipFiles(..))-import           Prelude                           hiding (FilePath, (++))-import           WaiAppStatic.Listing              (defaultListing)-import qualified Network.TLS as TLS-import qualified System.Directory as Dir--#if !MIN_VERSION_http_reverse_proxy(0,6,0)-defaultWaiProxySettings = def-#endif--#if !MIN_VERSION_http_reverse_proxy(0,4,2)-defaultLocalWaiProxySettings = def-#endif---data ProxySettings = MkProxySettings-  { -- | Mapping from virtual hostname to port number.-    psHostLookup     :: ByteString -> IO (Maybe (ProxyAction, TLS.Credentials))-  , psManager        :: !Manager-  , psConfig         :: !KeterConfig-  , psUnkownHost     :: ByteString -> ByteString-  , psMissingHost    :: ByteString-  , psProxyException :: ByteString-  , psLogException   :: Wai.Request -> SomeException -> IO ()-  }--makeSettings :: (LogMessage -> IO ()) -> KeterConfig -> HostMan.HostManager -> IO ProxySettings-makeSettings log psConfig@KeterConfig {..} hostman = do-    psManager <- HTTP.newManager HTTP.tlsManagerSettings-    psMissingHost <- case kconfigMissingHostResponse of-      Nothing -> pure defaultMissingHostBody-      Just x -> taggedReadFile "unknown-host-response-file" x-    psUnkownHost <- case kconfigUnknownHostResponse  of-                Nothing -> pure defaultUnknownHostBody-                Just x -> const <$> taggedReadFile "missing-host-response-file" x-    psProxyException <- case kconfigProxyException of-                Nothing -> pure defaultProxyException-                Just x -> taggedReadFile "proxy-exception-response-file" x-    pure $ MkProxySettings{..}-    where-        psLogException a b = log $ ProxyException a b-        psHostLookup = HostMan.lookupAction hostman . CI.mk--taggedReadFile :: String -> FilePath -> IO ByteString-taggedReadFile tag file = do-        isExist <- Dir.doesFileExist file-        if isExist then S.readFile file else do-          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-  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 =-    let-        newHooks@TLS.ServerHooks{..} = WarpTLS.tlsServerHooks s-        -- todo: add nested lookup-        newOnServerNameIndication (Just n) =-             maybe mempty snd <$> hl (S8.pack n)-        newOnServerNameIndication Nothing =-             return mempty -- we could return default certificate here-    in-        s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}-          , 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-  where-    useHeader :: Bool-    useHeader = kconfigIpFromHeader psConfig--    -- calculate the number of microseconds since the-    -- configuration option is in milliseconds-    bound :: Int-    bound = kconfigConnectionTimeBound psConfig * 1000-    protocol-        | isSecure = "https"-        | otherwise = "http"--    -- FIXME This is a workaround for-    -- https://github.com/snoyberg/keter/issues/29. After some research, it-    -- seems like Warp is behaving properly here. I'm still not certain why the-    -- http call (from http-conduit) inside waiProxyToSettings could ever block-    -- infinitely without the server it's connecting to going down, so that-    -- requires more research. Meanwhile, this prevents the file descriptor-    -- leak from occurring.--    addjustGlobalBound :: Maybe Int -> LocalWaiProxySettings-    addjustGlobalBound to = go `setLpsTimeBound` defaultLocalWaiProxySettings-      where-        go = case to <|> Just bound of-               Just x | x > 0 -> Just x-               _              -> Nothing--    getDest :: Wai.Request -> IO (LocalWaiProxySettings, WaiProxyResponse)-    getDest req =-        case Wai.requestHeaderHost req of-            Nothing -> do-              return (defaultLocalWaiProxySettings, WPRResponse $ missingHostResponse psMissingHost)-            Just host -> processHost req host--    processHost :: Wai.Request -> S.ByteString -> IO (LocalWaiProxySettings, WaiProxyResponse)-    processHost 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-            mport1 <- psHostLookup host-            case mport1 of-                Just _ -> return mport1-                Nothing -> do-                    let host' = S.takeWhile (/= 58) host-                    if host' == host-                        then return Nothing-                        else psHostLookup host'-        case mport of-            Nothing -> do-              return (defaultLocalWaiProxySettings, WPRResponse $ unknownHostResponse host (psUnkownHost host))-            Just ((action, requiresSecure), _)-                | requiresSecure && not isSecure -> performHttpsRedirect host req-                | otherwise -> performAction req action--    performHttpsRedirect host =-        return . (addjustGlobalBound Nothing,) . WPRResponse . redirectApp config-      where-        host' = CI.mk $ decodeUtf8With lenientDecode host-        config = RedirectConfig-            { redirconfigHosts = mempty-            , redirconfigStatus = 301-            , redirconfigActions = V.singleton $ RedirectAction SPAny-                                 $ RDPrefix True host' Nothing-            , redirconfigSsl = SSLTrue-            }--    performAction req (PAPort port tbound) =-        return (addjustGlobalBound tbound, WPRModifiedRequest req' $ ProxyDest "127.0.0.1" port)-      where-        req' = req-            { Wai.requestHeaders = ("X-Forwarded-Proto", protocol)-                                 : Wai.requestHeaders req-            }-    performAction _ (PAStatic StaticFilesConfig {..}) =-        return (addjustGlobalBound sfconfigTimeout, WPRApplication $ processMiddleware sfconfigMiddleware $ staticApp (defaultFileServerSettings sfconfigRoot)-            { ssListing =-                if sfconfigListings-                    then Just defaultListing-                    else Nothing-            })-    performAction req (PARedirect config) = return (addjustGlobalBound Nothing, WPRResponse $ redirectApp config req)-    performAction _ (PAReverseProxy config rpconfigMiddleware tbound) =-       return (addjustGlobalBound tbound, WPRApplication-                $ processMiddleware rpconfigMiddleware-                $ Rewrite.simpleReverseProxy psManager config-              )--redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response-redirectApp RedirectConfig {..} req =-    V.foldr checkAction noAction redirconfigActions-  where-    checkAction (RedirectAction SPAny dest) _ = sendTo $ mkUrl dest-    checkAction (RedirectAction (SPSpecific path) dest) other-        | encodeUtf8 path == Wai.rawPathInfo req = sendTo $ mkUrl dest-        | otherwise = other--    noAction = Wai.responseBuilder-        status404-        [("Content-Type", "text/plain")]-        (copyByteString "File not found")--    sendTo url = Wai.responseBuilder-        status-        [("Location", url)]-        (copyByteString url)--    status =-        case redirconfigStatus of-            301 -> status301-            302 -> status302-            303 -> status303-            307 -> status307-            i   -> mkStatus i $ S8.pack $ show i--    mkUrl (RDUrl url) = encodeUtf8 url-    mkUrl (RDPrefix isSecure host mport) = S.concat-        [ if isSecure then "https://" else "http://"-        , encodeUtf8 $ CI.original host-        , case mport of-            Nothing -> ""-            Just port-                | isSecure && port == 443 -> ""-                | not isSecure && port == 80 -> ""-                | otherwise -> S8.pack $ ':' : show port-        , Wai.rawPathInfo req-        , Wai.rawQueryString req-        ]--handleProxyException :: (Wai.Request -> SomeException -> IO ()) -> ByteString -> SomeException -> Wai.Application-handleProxyException handleException onexceptBody except req respond = do-  handleException req except-  respond $ missingHostResponse onexceptBody--defaultProxyException :: ByteString-defaultProxyException = "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>There was a proxy error, check the keter logs for details.</p></body></html>"--defaultMissingHostBody :: ByteString-defaultMissingHostBody = "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>You did not provide a virtual hostname for this request.</p></body></html>"--missingHostResponse :: ByteString -> Wai.Response-missingHostResponse missingHost = Wai.responseBuilder-    status502-    [("Content-Type", "text/html; charset=utf-8")]-    $ copyByteString missingHost--defaultUnknownHostBody :: ByteString -> ByteString-defaultUnknownHostBody host =-  "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>"-  <> escapeHtml host <> "</code>, is not recognized.</p></body></html>"--unknownHostResponse :: ByteString -> ByteString -> Wai.Response-unknownHostResponse host body = Wai.responseBuilder-    status404-    [("Content-Type", "text/html; charset=utf-8"),-     ("X-Forwarded-Host",-      -- if an attacker manages to insert line breaks somehow,-      -- this is also vulnerable.-      escapeHtml host-     )]-    (copyByteString body)--escapeHtml :: ByteString -> ByteString-escapeHtml = toByteString . fromHtmlEscapedByteString

@@ -1,26 +0,0 @@-module Keter.Types-    ( module X-    ) where--import Keter.Types.Common as X-import Keter.Types.V04 as X (PortSettings (..), TLSConfig (..))-import Keter.Types.V10 as X-    ( BundleConfig (..)-    , WebAppConfig (..)-    , RedirectConfig (..)-    , StaticFilesConfig (..)-    , KeterConfig (..)-    , Stanza (..)-    , StanzaRaw (..)-    , ProxyAction-    , ProxyActionRaw (..)-    , RedirectDest (..)-    , RedirectAction (..)-    , SourcePath (..)-    , ListeningPort (..)-    , AppInput (..)-    , BackgroundConfig (..)-    , RestartCount (..)-    , RequiresSecure-    )-import Network.HTTP.ReverseProxy.Rewrite as X (ReverseProxyConfig (..), RewriteRule (..))

@@ -1,237 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE TemplateHaskell    #-}-{-# LANGUAGE TypeFamilies       #-}--module Keter.Types.Common-    ( module Keter.Types.Common-    , FilePath-    , Text-    , ByteString-    , Set-    , Map-    , Exception-    , SomeException-    ) where--import qualified Network.Wai                       as Wai-import           Control.Exception          (Exception, SomeException)-import           Data.Aeson                 (FromJSON, Object, ToJSON,-                                             Value (Bool), object, withBool,-                                             withObject, (.!=), (.:?), (.=))-import           Data.ByteString            (ByteString)-import           Data.CaseInsensitive       (CI, original)-import           Data.Map                   (Map)-import           Data.Set                   (Set)-import qualified Data.Set                   as Set-import           Data.Text                  (Text, pack, unpack)-import           Data.Typeable              (Typeable)-import           Data.Vector                (Vector)-import qualified Data.Vector                as V-import qualified Data.Yaml-import           Data.Yaml.FilePath-import qualified Language.Haskell.TH.Syntax as TH-import           Network.Socket             (AddrInfo, SockAddr)-import           System.Exit                (ExitCode)-import           System.FilePath            (FilePath, takeBaseName)---- | Name of the application. Should just be the basename of the application--- file.-type Appname = Text--data Plugin = Plugin-    { pluginGetEnv :: Appname -> Object -> IO [(Text, Text)]-    }--type Plugins = [Plugin]---- | Used for versioning data types.-class ToCurrent a where-    type Previous a-    toCurrent :: Previous a -> a-instance ToCurrent a => ToCurrent (Maybe a) where-    type Previous (Maybe a) = Maybe (Previous a)-    toCurrent = fmap toCurrent---- | A port for an individual app to listen on.-type Port = Int---- | A virtual host we want to serve content from.-type Host = CI Text--type HostBS = CI ByteString--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-                    | InvalidConfigFile Data.Yaml.ParseException-                    | InvalidKeterConfigFile !FilePath !Data.Yaml.ParseException-                    | CannotReserveHosts !AppId !(Map Host AppId)-                    | FileNotExecutable !FilePath-                    | ExecutableNotFound !FilePath-                    | 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)-instance Show AppId where-    show AIBuiltin   = "/builtin/"-    show (AINamed t) = unpack t--data SSLConfig-    = SSLFalse-    | SSLTrue-    | SSL !FilePath !(Vector FilePath) !FilePath-    deriving (Show, Eq, Ord)--instance ParseYamlFile SSLConfig where-    parseYamlFile _ v@(Bool _) =-        withBool "ssl" ( \b ->-            return (if b then SSLTrue else SSLFalse) ) v-    parseYamlFile basedir v =  withObject "ssl" ( \o -> do-             mcert <- lookupBaseMaybe basedir o "certificate"-             mkey <- lookupBaseMaybe basedir o "key"-             case (mcert, mkey) of-                 (Just cert, Just key) -> do-                     chainCerts <- o .:? "chain-certificates"-                         >>= maybe (return V.empty) (parseYamlFile basedir)-                     return $ SSL cert chainCerts key-                 _ -> return SSLFalse-            ) v--instance ToJSON SSLConfig where-    toJSON SSLTrue = Bool True-    toJSON SSLFalse = Bool False-    toJSON (SSL c cc k) = object [ "certificate" .= c-                                 , "chain-certificates" .= cc-                                 , "key" .= k-                                 ]-instance FromJSON SSLConfig where-    parseJSON v@(Bool _) = withBool "ssl" ( \b ->-                    return (if b then SSLTrue else SSLFalse) ) v-    parseJSON v = withObject "ssl" ( \o -> do-                    mcert <- o .:? "certificate"-                    mkey <- o .:? "key"-                    case (mcert, mkey) of-                        (Just cert, Just key) -> do-                            chainCerts <- o .:? "chain-certificates" .!= V.empty-                            return $ SSL cert chainCerts key-                        _ -> return SSLFalse -- fail "Must provide both certificate and key files"-                    ) v

@@ -1,99 +0,0 @@-{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}--module Keter.Types.Middleware where--import Data.Aeson-import GHC.Generics-import Prelude-import Network.Wai--import Control.Monad-import Control.Arrow ((***))---- various Middlewares-import Network.Wai.Middleware.AcceptOverride  (acceptOverride)-import Network.Wai.Middleware.Autohead        (autohead)-import Network.Wai.Middleware.Jsonp           (jsonp)-import Network.Wai.Middleware.Local           (local)-import Network.Wai.Middleware.AddHeaders      (addHeaders)-import Network.Wai.Middleware.MethodOverride  (methodOverride)-import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)-import Network.Wai.Middleware.HttpAuth        (basicAuth)--import Data.ByteString.Lazy         as L (ByteString)-import Data.ByteString  as S (ByteString)--import Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8)-import Data.Text.Encoding as T (encodeUtf8, decodeUtf8)-import Data.String (fromString)-import qualified Data.Aeson.KeyHelper as AK (toKey, toText, toList, empty)--data MiddlewareConfig = AcceptOverride-                      | Autohead-                      | Jsonp-                      | MethodOverride-                      | MethodOverridePost-                      | AddHeaders ![(S.ByteString, S.ByteString)]-                      | BasicAuth !String ![(S.ByteString, S.ByteString)]-                         -- ^ Realm [(username,password)]-                      | Local !Int !L.ByteString-                         -- ^ Status Message-          deriving (Show,Generic)--instance FromJSON MiddlewareConfig where-  parseJSON (String "accept-override"     ) = pure AcceptOverride-  parseJSON (String "autohead"            ) = pure Autohead-  parseJSON (String "jsonp"               ) = pure Jsonp-  parseJSON (String "method-override"     ) = pure MethodOverride-  parseJSON (String "method-override-post") = pure MethodOverridePost-  parseJSON (Object o) =-     case AK.toList o of-      [("basic-auth", Object ( o'))] -> BasicAuth  <$> o' .:? "realm" .!= "keter"-                                                <*> (map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8) . AK.toList <$> o' .:? "creds"   .!= AK.empty)-      [("headers"   , Object _ )]    -> AddHeaders . map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8) . AK.toList <$> o  .:? "headers" .!= AK.empty-      [("local"     , Object o')] -> Local  <$> o' .:? "status" .!=  401-                                            <*> (TL.encodeUtf8 <$> o' .:? "message" .!= "Unauthorized Accessing from Localhost ONLY" )-      _                      -> mzero -- fail "Rule: unexpected format"-  parseJSON _ = mzero--instance ToJSON MiddlewareConfig where-  toJSON AcceptOverride     = "accept-override"-  toJSON Autohead           = "autohead"-  toJSON Jsonp              = "jsonp"-  toJSON MethodOverride     = "method-override"-  toJSON MethodOverridePost = "method-override-post"-  toJSON (BasicAuth realm cred) = object [ "basic-auth" .= object [ "realm" .= realm-                                                                  , "creds" .= object ( map ( (AK.toKey . T.decodeUtf8) *** (String . T.decodeUtf8)) cred )-                                                                  ]-                                         ]-  toJSON (AddHeaders headers)   = object [ "headers"    .= object ( map ((AK.toKey . T.decodeUtf8) *** String . T.decodeUtf8) headers)  ]-  toJSON (Local sc msg)         = object [ "local"      .= object [ "status" .= sc-                                                                  , "message" .=  TL.decodeUtf8 msg -                                                                  ]-                                         ]---{-- Still missing--- CleanPath--- Gzip--- RequestLogger--- Rewrite--- Vhost---}--processMiddleware :: [MiddlewareConfig] -> Middleware-processMiddleware = composeMiddleware . map toMiddleware--toMiddleware :: MiddlewareConfig -> Middleware-toMiddleware AcceptOverride     = acceptOverride-toMiddleware Autohead           = autohead-toMiddleware Jsonp              = jsonp-toMiddleware (Local s c )       = local ( responseLBS (toEnum s) [] c )-toMiddleware MethodOverride     = methodOverride-toMiddleware MethodOverridePost = methodOverridePost-toMiddleware (BasicAuth realm cred) = basicAuth (\u p -> return $ maybe False (==p) $ lookup u cred ) (fromString realm)-toMiddleware (AddHeaders headers)   = addHeaders headers---- composeMiddleware :-composeMiddleware :: [Middleware] -> Middleware-composeMiddleware = foldl (flip (.)) id

@@ -1,157 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Legacy types from Keter version 0.4. Retained to keep backwards--- compatibility in config file format.-module Keter.Types.V04 where--import           Control.Applicative-import           Data.Aeson-import           Data.Bool-import           Data.Conduit.Network              (HostPreference)-import           Data.Default-import qualified Data.Set                          as Set-import           Data.String                       (fromString)-import           Data.Yaml.FilePath-import qualified System.FilePath                   as F-import           Keter.Types.Common-import           Network.HTTP.ReverseProxy.Rewrite-import qualified Network.Wai.Handler.Warp          as Warp-import qualified Network.Wai.Handler.WarpTLS       as WarpTLS-import qualified Network.TLS.SessionManager        as TLSSession-import           Prelude                           hiding (FilePath)--data AppConfig = AppConfig-    { configExec       :: F.FilePath-    , configArgs       :: [Text]-    , configHost       :: Text-    , configSsl        :: Bool-    , configExtraHosts :: Set Text-    , configRaw        :: Object-    }--instance ParseYamlFile AppConfig where-    parseYamlFile basedir = withObject "AppConfig" $ \o -> AppConfig-        <$> lookupBase basedir o "exec"-        <*> o .:? "args" .!= []-        <*> o .: "host"-        <*> o .:? "ssl" .!= False-        <*> o .:? "extra-hosts" .!= Set.empty-        <*> return o--data BundleConfig = BundleConfig-    { bconfigApp         :: Maybe AppConfig-    , bconfigStaticHosts :: Set StaticHost-    , bconfigRedirects   :: Set Redirect-    }--instance ParseYamlFile BundleConfig where-    parseYamlFile basedir = withObject "BundleConfig" $ \o -> BundleConfig-        <$> ((Just <$> parseYamlFile basedir (Object o)) <|> pure Nothing)-        <*> lookupBaseMaybe basedir o "static-hosts" .!= Set.empty-        <*> o .:? "redirects" .!= Set.empty--data StaticHost = StaticHost-    { shHost :: Text-    , shRoot :: FilePath-    }-    deriving (Eq, Ord)--instance ParseYamlFile StaticHost where-    parseYamlFile basedir = withObject "StaticHost" $ \o -> StaticHost-        <$> o .: "host"-        <*> lookupBase basedir o "root"--data Redirect = Redirect-    { redFrom :: Text-    , redTo   :: Text-    }-    deriving (Eq, Ord)--instance FromJSON Redirect where-    parseJSON (Object o) = Redirect-        <$> o .: "from"-        <*> o .: "to"-    parseJSON _ = fail "Wanted an object"--data KeterConfig = KeterConfig-    { kconfigDir                 :: F.FilePath-    , kconfigPortMan             :: PortSettings-    , kconfigHost                :: HostPreference-    , kconfigPort                :: Port-    , kconfigSsl                 :: Maybe TLSConfig-    , kconfigSetuid              :: Maybe Text-    , kconfigReverseProxy        :: Set ReverseProxyConfig-    , kconfigIpFromHeader        :: Bool-    , kconfigConnectionTimeBound :: Int-    -- ^ Maximum request time in milliseconds per connection.-    }--instance Default KeterConfig where-    def = KeterConfig-        { kconfigDir = "."-        , kconfigPortMan = def-        , kconfigHost = "*"-        , kconfigPort = 80-        , kconfigSsl = Nothing-        , kconfigSetuid = Nothing-        , kconfigReverseProxy = Set.empty-        , kconfigIpFromHeader = False-        , kconfigConnectionTimeBound = fiveMinutes-        }----- | Default connection time bound in milliseconds.-fiveMinutes :: Int-fiveMinutes = 5 * 60 * 1000--instance ParseYamlFile KeterConfig where-    parseYamlFile basedir = withObject "KeterConfig" $ \o -> KeterConfig-        <$> lookupBase basedir o "root"-        <*> o .:? "port-manager" .!= def-        <*> (fmap fromString <$> o .:? "host") .!= kconfigHost def-        <*> o .:? "port" .!= kconfigPort def-        <*> (o .:? "ssl" >>= maybe (return Nothing) (fmap Just . parseYamlFile basedir))-        <*> o .:? "setuid"-        <*> o .:? "reverse-proxy" .!= Set.empty-        <*> o .:? "ip-from-header" .!= False-        <*> o .:? "connection-time-bound" .!= fiveMinutes--data TLSConfig = TLSConfig !Warp.Settings !FilePath !FilePath (Maybe TLSSession.Config)--instance ParseYamlFile TLSConfig where-    parseYamlFile basedir = withObject "TLSConfig" $ \o -> do-        cert <- lookupBase basedir o "certificate"-        key <- lookupBase basedir o "key"-        host <- (fmap fromString <$> o .:? "host") .!= "*"-        port <- o .:? "port" .!= 443-        session <- bool Nothing (Just TLSSession.defaultConfig) <$> o .:? "session" .!= False-        return $! TLSConfig-            (Warp.setHost host $ Warp.setPort port Warp.defaultSettings)-            cert-            key-            session---- | Controls execution of the nginx thread. Follows the settings type pattern.--- See: <http://www.yesodweb.com/book/settings-types>.-data PortSettings = PortSettings-    { portRange :: [Port]-      -- ^ Which ports to assign to apps. Defaults to unassigned ranges from IANA-    }--instance Default PortSettings where-    def = PortSettings-        -- Top 10 Largest IANA unassigned port ranges with no unauthorized uses known-        { portRange = [43124..44320]-                      ++ [28120..29166]-                      ++ [45967..46997]-                      ++ [28241..29117]-                      ++ [40001..40840]-                      ++ [29170..29998]-                      ++ [38866..39680]-                      ++ [43442..44122]-                      ++ [41122..41793]-                      ++ [35358..36000]-        }--instance FromJSON PortSettings where-    parseJSON = withObject "PortSettings" $ \_ -> PortSettings-        <$> return (portRange def)

@@ -1,478 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TypeFamilies      #-}-module Keter.Types.V10 where--import           Control.Applicative               ((<$>), (<*>), (<|>))-import           Data.Aeson                        (FromJSON (..), ToJSON (..), Object,-                                                    Value (Object, String, Bool),-                                                    withObject, (.!=), (.:),-                                                    (.:?), object, (.=))-import           Data.Aeson.KeyHelper              as AK (lookup, singleton, empty, insert)-import qualified Data.CaseInsensitive              as CI-import           Data.Conduit.Network              (HostPreference)-import           Data.Default-import qualified Data.Map                          as Map-import           Data.Maybe                        (catMaybes, fromMaybe, isJust)-import qualified Data.Set                          as Set-import           Data.String                       (fromString)-import           Data.Vector                       (Vector)-import qualified Data.Vector                       as V-import           Data.Word                         (Word)-import           Data.Yaml.FilePath-import qualified System.FilePath                   as F-import           Keter.Types.Common-import           Keter.Types.Middleware-import qualified Keter.Types.V04                   as V04-import           Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig)-import qualified Network.Wai.Handler.Warp          as Warp-import qualified Network.Wai.Handler.WarpTLS       as WarpTLS-import           System.Posix.Types                (EpochTime)--data BundleConfig = BundleConfig-    { bconfigStanzas :: !(Vector (Stanza ()))-    , bconfigPlugins :: !Object -- ^ settings used for plugins-    } deriving Show--instance ToCurrent BundleConfig where-    type Previous BundleConfig = V04.BundleConfig-    toCurrent (V04.BundleConfig webapp statics redirs) = BundleConfig-        { bconfigStanzas = V.concat-            [ maybe V.empty V.singleton $ fmap (flip Stanza False . StanzaWebApp . toCurrent) webapp-            , V.fromList $ map (flip Stanza False . StanzaStaticFiles . toCurrent) $ Set.toList statics-            , V.fromList $ map (flip Stanza False . StanzaRedirect . toCurrent) $ Set.toList redirs-            ]-        , bconfigPlugins =-            case webapp >>= AK.lookup "postgres" . V04.configRaw of-                Just (Bool True) -> AK.singleton "postgres" (Bool True)-                _ -> AK.empty-        }--instance ParseYamlFile BundleConfig where-    parseYamlFile basedir = withObject "BundleConfig" $ \o ->-        case AK.lookup "stanzas" o of-            Nothing -> (toCurrent :: V04.BundleConfig -> BundleConfig) <$> parseYamlFile basedir (Object o)-            Just _ -> current o-      where-        current o = BundleConfig-            <$> lookupBase basedir o "stanzas"-            <*> o .:? "plugins" .!= AK.empty--instance ToJSON BundleConfig where-    toJSON BundleConfig {..} = object-        [ "stanzas" .= bconfigStanzas-        , "plugins" .= bconfigPlugins-        ]--data ListeningPort = LPSecure !HostPreference !Port-                              !F.FilePath !(V.Vector F.FilePath) !F.FilePath-                              !Bool-                   | LPInsecure !HostPreference !Port--instance ParseYamlFile ListeningPort where-    parseYamlFile basedir = withObject "ListeningPort" $ \o -> do-        host <- (fmap fromString <$> o .:? "host") .!= "*"-        mcert <- lookupBaseMaybe basedir o "certificate"-        mkey <- lookupBaseMaybe basedir o "key"-        session <- o .:? "session" .!= False-        case (mcert, mkey) of-            (Nothing, Nothing) -> do-                port <- o .:? "port" .!= 80-                return $ LPInsecure host port-            (Just cert, Just key) -> do-                port <- o .:? "port" .!= 443-                chainCerts <- o .:? "chain-certificates"-                    >>= maybe (return V.empty) (parseYamlFile basedir)-                return $ LPSecure host port cert chainCerts key session-            _ -> fail "Must provide both certificate and key files"--data KeterConfig = KeterConfig-    { kconfigDir                 :: F.FilePath-    , kconfigPortPool            :: V04.PortSettings-    , kconfigListeners           :: !(NonEmptyVector ListeningPort)-    , kconfigSetuid              :: Maybe Text-    , kconfigBuiltinStanzas      :: !(V.Vector (Stanza ()))-    , kconfigIpFromHeader        :: Bool-    , kconfigExternalHttpPort    :: !Int-    -- ^ External HTTP port when generating APPROOTs.-    , kconfigExternalHttpsPort   :: !Int-    -- ^ External HTTPS port when generating APPROOTs.-    , kconfigEnvironment         :: !(Map Text Text)-    -- ^ Environment variables to be passed to all apps.-    , kconfigConnectionTimeBound :: !Int-    -- ^ Maximum request time in milliseconds per connection.-    , kconfigCliPort             :: !(Maybe Port)-    -- ^ Port for the cli to listen on--    , kconfigUnknownHostResponse  :: !(Maybe F.FilePath)-    , kconfigMissingHostResponse  :: !(Maybe F.FilePath)-    , kconfigProxyException       :: !(Maybe F.FilePath)-    }--instance ToCurrent KeterConfig where-    type Previous KeterConfig = V04.KeterConfig-    toCurrent (V04.KeterConfig dir portman host port ssl setuid rproxy ipFromHeader connectionTimeBound) = KeterConfig-        { kconfigDir = dir-        , kconfigPortPool = portman-        , kconfigListeners = NonEmptyVector (LPInsecure host port) (getSSL ssl)-        , kconfigSetuid = setuid-        , kconfigBuiltinStanzas = V.fromList $ map (flip Stanza False . (\rp -> StanzaReverseProxy rp [] Nothing)) $ Set.toList rproxy-        , kconfigIpFromHeader = ipFromHeader-        , kconfigExternalHttpPort = 80-        , kconfigExternalHttpsPort = 443-        , kconfigEnvironment = Map.empty-        , kconfigConnectionTimeBound = connectionTimeBound-        , kconfigCliPort             = Nothing-        , kconfigUnknownHostResponse  = Nothing-        , kconfigMissingHostResponse = Nothing-        , kconfigProxyException      = Nothing-        }-      where-        getSSL Nothing = V.empty-        getSSL (Just (V04.TLSConfig s cert key session)) = V.singleton $ LPSecure-            (Warp.getHost s)-            (Warp.getPort s)-            cert-            V.empty-            key-            (isJust session)--instance Default KeterConfig where-    def = KeterConfig-        { kconfigDir = "."-        , kconfigPortPool = def-        , kconfigListeners = NonEmptyVector (LPInsecure "*" 80) V.empty-        , kconfigSetuid = Nothing-        , kconfigBuiltinStanzas = V.empty-        , kconfigIpFromHeader = False-        , kconfigExternalHttpPort = 80-        , kconfigExternalHttpsPort = 443-        , kconfigEnvironment = Map.empty-        , kconfigConnectionTimeBound = V04.fiveMinutes-        , kconfigCliPort             = Nothing-        , kconfigUnknownHostResponse  = Nothing-        , kconfigMissingHostResponse = Nothing-        , kconfigProxyException      = Nothing-        }--instance ParseYamlFile KeterConfig where-    parseYamlFile basedir = withObject "KeterConfig" $ \o ->-        case AK.lookup "listeners" o of-            Just _ -> current o-            Nothing -> old o <|> current o-      where-        old o = (toCurrent :: V04.KeterConfig -> KeterConfig) <$> parseYamlFile basedir (Object o)-        current o = KeterConfig-            <$> lookupBase basedir o "root"-            <*> o .:? "port-manager" .!= def-            <*> fmap (fromMaybe (kconfigListeners def)) (lookupBaseMaybe basedir o "listeners")-            <*> o .:? "setuid"-            <*> return V.empty-            <*> o .:? "ip-from-header" .!= False-            <*> o .:? "external-http-port" .!= 80-            <*> o .:? "external-https-port" .!= 443-            <*> o .:? "env" .!= Map.empty-            <*> o .:? "connection-time-bound" .!= V04.fiveMinutes-            <*> o .:? "cli-port"-            <*> o .:? "missing-host-response-file"-            <*> o .:? "unknown-host-response-file"-            <*> o .:? "proxy-exception-response-file"---- | Whether we should force redirect to HTTPS routes.-type RequiresSecure = Bool--data Stanza port = Stanza (StanzaRaw port) RequiresSecure-  deriving Show--data StanzaRaw port-    = StanzaStaticFiles !StaticFilesConfig-    | StanzaRedirect !RedirectConfig-    | StanzaWebApp !(WebAppConfig port)-    | StanzaReverseProxy !ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)-    | StanzaBackground !BackgroundConfig-            -- FIXME console app-    deriving Show---- | An action to be performed for a requested hostname.------ This datatype is very similar to Stanza, but is necessarily separate since:------ 1. Webapps will be assigned ports.------ 2. Not all stanzas have an associated proxy action.-data ProxyActionRaw-    = PAPort Port !(Maybe Int)-    | PAStatic StaticFilesConfig-    | PARedirect RedirectConfig-    | PAReverseProxy ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)-    deriving Show--type ProxyAction = (ProxyActionRaw, RequiresSecure)--instance ParseYamlFile (Stanza ()) where-    parseYamlFile basedir = withObject "Stanza" $ \o -> do-        typ <- o .: "type"-        needsHttps <- o .:? "requires-secure" .!= False-        raw <- case typ of-            "static-files"  -> fmap StanzaStaticFiles $ parseYamlFile basedir $ Object o-            "redirect"      -> fmap StanzaRedirect $ parseYamlFile basedir $ Object o-            "webapp"        -> fmap StanzaWebApp $ parseYamlFile basedir $ Object o-            "reverse-proxy" -> StanzaReverseProxy <$> parseJSON (Object o)-                                                  <*> o .:? "middleware" .!= []-                                                  <*> o .:? "connection-time-bound"-            "background"    -> fmap StanzaBackground $ parseYamlFile basedir $ Object o-            _ -> fail $ "Unknown stanza type: " ++ typ-        return $ Stanza raw needsHttps--instance ToJSON (Stanza ()) where-    toJSON (Stanza raw rs) = addRequiresSecure rs raw--addRequiresSecure :: ToJSON a => Bool -> a -> Value-addRequiresSecure rs x =-    case toJSON x of-        Object o -> Object $ AK.insert "requires-secure" (toJSON rs) o-        v -> v--instance ToJSON (StanzaRaw ()) where-    toJSON (StanzaStaticFiles x) = addStanzaType "static-files" x-    toJSON (StanzaRedirect x) = addStanzaType "redirect" x-    toJSON (StanzaWebApp x) = addStanzaType "webapp" x-    toJSON (StanzaReverseProxy x _ _) = addStanzaType "reverse-proxy" x-    toJSON (StanzaBackground x) = addStanzaType "background" x--addStanzaType :: ToJSON a => Value -> a -> Value-addStanzaType t x =-    case toJSON x of-        Object o -> Object $ AK.insert "type" t o-        v -> v--data StaticFilesConfig = StaticFilesConfig-    { sfconfigRoot       :: !F.FilePath-    , sfconfigHosts      :: !(Set Host)-    , sfconfigListings   :: !Bool-    -- FIXME basic auth-    , sfconfigMiddleware :: ![ MiddlewareConfig ]-    , sfconfigTimeout    :: !(Maybe Int)-    , sfconfigSsl        :: !SSLConfig-    }-    deriving Show--instance ToCurrent StaticFilesConfig where-    type Previous StaticFilesConfig = V04.StaticHost-    toCurrent (V04.StaticHost host root) = StaticFilesConfig-        { sfconfigRoot       = root-        , sfconfigHosts      = Set.singleton $ CI.mk host-        , sfconfigListings   = True-        , sfconfigMiddleware = []-        , sfconfigTimeout    = Nothing-        , sfconfigSsl        = SSLFalse-        }--instance ParseYamlFile StaticFilesConfig where-    parseYamlFile basedir = withObject "StaticFilesConfig" $ \o -> StaticFilesConfig-        <$> lookupBase basedir o "root"-        <*> (Set.map CI.mk <$> (o .: "hosts" <|> (Set.singleton <$> (o .: "host"))))-        <*> o .:? "directory-listing" .!= False-        <*> o .:? "middleware" .!= []-        <*> o .:? "connection-time-bound"-        <*> o .:? "ssl" .!= SSLFalse--instance ToJSON StaticFilesConfig where-    toJSON StaticFilesConfig {..} = object-        [ "root" .= sfconfigRoot-        , "hosts" .= Set.map CI.original sfconfigHosts-        , "directory-listing" .= sfconfigListings-        , "middleware" .= sfconfigMiddleware-        , "connection-time-bound" .= sfconfigTimeout-        , "ssl" .= sfconfigSsl-        ]--data RedirectConfig = RedirectConfig-    { redirconfigHosts   :: !(Set Host)-    , redirconfigStatus  :: !Int-    , redirconfigActions :: !(Vector RedirectAction)-    , redirconfigSsl     :: !SSLConfig-    }-    deriving Show--instance ToCurrent RedirectConfig where-    type Previous RedirectConfig = V04.Redirect-    toCurrent (V04.Redirect from to) = RedirectConfig-        { redirconfigHosts = Set.singleton $ CI.mk from-        , redirconfigStatus = 301-        , redirconfigActions = V.singleton $ RedirectAction SPAny-                             $ RDPrefix False (CI.mk to) Nothing-        , redirconfigSsl = SSLFalse-        }--instance ParseYamlFile RedirectConfig where-    parseYamlFile _ = withObject "RedirectConfig" $ \o -> RedirectConfig-        <$> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host")))))-        <*> o .:? "status" .!= 303-        <*> o .: "actions"-        <*> o .:? "ssl" .!= SSLFalse--instance ToJSON RedirectConfig where-    toJSON RedirectConfig {..} = object-        [ "hosts" .= Set.map CI.original redirconfigHosts-        , "status" .= redirconfigStatus-        , "actions" .= redirconfigActions-        , "ssl" .= redirconfigSsl-        ]--data RedirectAction = RedirectAction !SourcePath !RedirectDest-    deriving Show--instance FromJSON RedirectAction where-    parseJSON = withObject "RedirectAction" $ \o -> RedirectAction-        <$> (maybe SPAny SPSpecific <$> (o .:? "path"))-        <*> parseJSON (Object o)--instance ToJSON RedirectAction where-    toJSON (RedirectAction path dest) =-        case toJSON dest of-            Object o ->-                case path of-                    SPAny -> Object o-                    SPSpecific x -> Object $ AK.insert "path" (String x) o-            v -> v--data SourcePath = SPAny-                | SPSpecific !Text-    deriving Show--data RedirectDest = RDUrl !Text-                  | RDPrefix !IsSecure !Host !(Maybe Port)-    deriving Show--instance FromJSON RedirectDest where-    parseJSON = withObject "RedirectDest" $ \o ->-        url o <|> prefix o-      where-        url o = RDUrl <$> o .: "url"-        prefix o = RDPrefix-            <$> o .:? "secure" .!= False-            <*> (CI.mk <$> o .: "host")-            <*> o .:? "port"--instance ToJSON RedirectDest where-    toJSON (RDUrl url) = object ["url" .= url]-    toJSON (RDPrefix secure host mport) = object $ catMaybes-        [ Just $ "secure" .= secure-        , Just $ "host" .= CI.original host-        , case mport of-            Nothing -> Nothing-            Just port -> Just $ "port" .= port-        ]--type IsSecure = Bool--data WebAppConfig port = WebAppConfig-    { waconfigExec        :: !F.FilePath-    , waconfigArgs        :: !(Vector Text)-    , waconfigEnvironment :: !(Map Text Text)-    , waconfigApprootHost :: !Host -- ^ primary host, used for approot-    , waconfigHosts       :: !(Set Host) -- ^ all hosts, not including the approot host-    , waconfigSsl         :: !SSLConfig-    , waconfigPort        :: !port-    , waconfigForwardEnv  :: !(Set Text)-     -- | how long are connections supposed to last-    , waconfigTimeout     :: !(Maybe Int)-     -- | how long in microseconds the app gets before we expect it to bind to-     --   a port (default 90 seconds)-    , waconfigEnsureAliveTimeout :: !(Maybe Int)-    }-    deriving Show--instance ToCurrent (WebAppConfig ()) where-    type Previous (WebAppConfig ()) = V04.AppConfig-    toCurrent (V04.AppConfig exec args host ssl hosts _raw) = WebAppConfig-        { waconfigExec = exec-        , waconfigArgs = V.fromList args-        , waconfigEnvironment = Map.empty-        , waconfigApprootHost = CI.mk host-        , waconfigHosts = Set.map CI.mk hosts-        , waconfigSsl = if ssl then SSLTrue else SSLFalse-        , waconfigPort = ()-        , waconfigForwardEnv = Set.empty-        , waconfigTimeout = Nothing-        , waconfigEnsureAliveTimeout = Nothing-        }--instance ParseYamlFile (WebAppConfig ()) where-    parseYamlFile basedir = withObject "WebAppConfig" $ \o -> do-        (ahost, hosts) <--            (do-                h <- o .: "host"-                return (CI.mk h, Set.empty)) <|>-            (do-                hs <- o .: "hosts"-                case hs of-                    [] -> fail "Must provide at least one host"-                    h:hs' -> return (CI.mk h, Set.fromList $ map CI.mk hs'))-        WebAppConfig-            <$> lookupBase basedir o "exec"-            <*> o .:? "args" .!= V.empty-            <*> o .:? "env" .!= Map.empty-            <*> return ahost-            <*> return hosts-            <*> o .:? "ssl" .!= SSLFalse-            <*> return ()-            <*> o .:? "forward-env" .!= Set.empty-            <*> o .:? "connection-time-bound"-            <*> o .:? "ensure-alive-time-bound"--instance ToJSON (WebAppConfig ()) where-    toJSON WebAppConfig {..} = object-        [ "exec" .= waconfigExec-        , "args" .= waconfigArgs-        , "env" .= waconfigEnvironment-        , "hosts" .= map CI.original (waconfigApprootHost : Set.toList waconfigHosts)-        , "ssl" .= waconfigSsl-        , "forward-env" .= waconfigForwardEnv-        , "connection-time-bound" .= waconfigTimeout-        ]--data AppInput = AIBundle !FilePath !EpochTime-              | AIData !BundleConfig-              deriving Show--data BackgroundConfig = BackgroundConfig-    { bgconfigExec                :: !F.FilePath-    , bgconfigArgs                :: !(Vector Text)-    , bgconfigEnvironment         :: !(Map Text Text)-    , bgconfigRestartCount        :: !RestartCount-    , bgconfigRestartDelaySeconds :: !Word-    , bgconfigForwardEnv          :: !(Set Text)-    }-    deriving Show--data RestartCount = UnlimitedRestarts | LimitedRestarts !Word-    deriving Show--instance FromJSON RestartCount where-    parseJSON (String "unlimited") = return UnlimitedRestarts-    parseJSON v = LimitedRestarts <$> parseJSON v--instance ParseYamlFile BackgroundConfig where-    parseYamlFile basedir = withObject "BackgroundConfig" $ \o -> BackgroundConfig-        <$> lookupBase basedir o "exec"-        <*> o .:? "args" .!= V.empty-        <*> o .:? "env" .!= Map.empty-        <*> o .:? "restart-count" .!= UnlimitedRestarts-        <*> o .:? "restart-delay-seconds" .!= 5-        <*> o .:? "forward-env" .!= Set.empty--instance ToJSON BackgroundConfig where-    toJSON BackgroundConfig {..} = object $ catMaybes-        [ Just $ "exec" .= bgconfigExec-        , Just $ "args" .= bgconfigArgs-        , Just $ "env" .= bgconfigEnvironment-        , case bgconfigRestartCount of-            UnlimitedRestarts -> Nothing-            LimitedRestarts count -> Just $ "restart-count" .= count-        , Just $ "restart-delay-seconds" .= bgconfigRestartDelaySeconds-        , Just $ "forward-env" .= bgconfigForwardEnv-        ]

@@ -1,231 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE CPP               #-}-module Network.HTTP.ReverseProxy.Rewrite-  ( ReverseProxyConfig (..)-  , RewriteRule (..)-  , RPEntry (..)-  , simpleReverseProxy-  )-  where--import Control.Applicative-import Control.Exception (bracket)-import Data.Function (fix)-import Data.Monoid ((<>))--import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Map as Map-import Data.Map ( Map )-import Data.Array ((!))-import Data.Aeson-import Control.Monad (unless)--import qualified Data.ByteString as S-import qualified Data.Text as T-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import qualified Data.CaseInsensitive as CI--import Blaze.ByteString.Builder (fromByteString)--import Keter.Types.Common--- Configuration files-import Data.Default---- Regular expression parsing, replacement, matching-import Data.Attoparsec.Text (string, takeWhile1, endOfInput, parseOnly, Parser)-import Text.Regex.TDFA (makeRegex, matchOnceText, MatchText)-import Text.Regex.TDFA.String (Regex)-import Data.Char (isDigit)---- Reverse proxy apparatus-import qualified Network.Wai as Wai-import qualified Network.Wai.Internal as I-import Network.HTTP.Client.Conduit-import qualified Network.HTTP.Client as NHC-import Network.HTTP.Types--data RPEntry = RPEntry-    { config :: ReverseProxyConfig-    , httpManager :: Manager-    }--instance Show RPEntry where-  show x = "RPEntry { config = " ++ (show $ config x) ++ " }"--getGroup :: MatchText String -> Int -> String-getGroup matches i = fst $ matches ! i--rewrite :: (String, MatchText String, String) -> String -> String -> Text-rewrite (before, match, after) input replacement =-  case parseOnly parseSubstitute (T.pack replacement) of-    Left _ -> T.pack input-    Right result -> T.pack before <> result <> T.pack after-  where-    parseSubstitute :: Parser Text-    parseSubstitute =-          (endOfInput >> "")-      <|> do-          { _ <- string "\\\\"-          ; rest <- parseSubstitute-          ; return $ "\\" <> rest-          }-      <|> do-          { _ <- string "\\"-          ; n <- (fmap (read . T.unpack) $ takeWhile1 isDigit) :: Parser Int-          ; rest <- parseSubstitute-          ; return $ T.pack (getGroup match n) <> rest-          }-      <|> do-          { text <- takeWhile1 (/= '\\')-          ; rest <- parseSubstitute-          ; return $ text <> rest-          }--rewriteHeader :: Map HeaderName RewriteRule -> Header -> Header-rewriteHeader rules header@(name, value) =-  case Map.lookup name rules of-    Nothing -> header-    Just  r -> (name, regexRewrite r value)--rewriteHeaders :: Map HeaderName RewriteRule -> [Header] -> [Header]-rewriteHeaders ruleMap = map (rewriteHeader ruleMap)--regexRewrite :: RewriteRule -> S.ByteString -> S.ByteString-regexRewrite (RewriteRule _ regex' replacement) input =-  case matchOnceText regex strInput of-    Just  match -> encodeUtf8 $ rewrite match strInput strReplacement-    Nothing     -> input-  where-    strRegex = T.unpack regex'-    regex :: Regex-    regex = makeRegex strRegex-    strInput = T.unpack . decodeUtf8 $ input-    strReplacement = T.unpack replacement--filterHeaders :: [Header] -> [Header]-filterHeaders = filter useHeader-  where-    useHeader ("Transfer-Encoding", _) = False-    useHeader ("Content-Length", _)    = False-    useHeader ("Host", _)              = False-    useHeader _                        = True--mkRuleMap :: Set RewriteRule -> Map HeaderName RewriteRule-mkRuleMap = Map.fromList . map (\k -> (CI.mk . encodeUtf8 $ ruleHeader k, k)) . Set.toList--mkRequest :: ReverseProxyConfig -> Wai.Request -> Request-mkRequest rpConfig request =-#if MIN_VERSION_http_client(0, 5, 0)-   NHC.defaultRequest-      { NHC.checkResponse = \_ _ -> return ()-      , NHC.responseTimeout = maybe NHC.responseTimeoutNone NHC.responseTimeoutMicro $ reverseTimeout rpConfig-#else-   def-      { NHC.checkStatus = \_ _ _ -> Nothing-      , NHC.responseTimeout = reverseTimeout rpConfig-#endif-      , method = Wai.requestMethod request-      , secure = reversedUseSSL rpConfig-      , host   = encodeUtf8 $ reversedHost rpConfig-      , port   = reversedPort rpConfig-      , path   = Wai.rawPathInfo request-      , queryString = Wai.rawQueryString request-      , requestHeaders = filterHeaders $ rewriteHeaders reqRuleMap (Wai.requestHeaders request)-      , requestBody =-          case Wai.requestBodyLength request of-            Wai.ChunkedBody   -> RequestBodyStreamChunked ($ I.getRequestBodyChunk request)-            Wai.KnownLength n -> RequestBodyStream (fromIntegral n) ($ I.getRequestBodyChunk request)-      , decompress = const False-      , redirectCount = 0-      , cookieJar = Nothing-      , requestVersion = Wai.httpVersion request-      }-  where-    reqRuleMap = mkRuleMap $ rewriteRequestRules rpConfig--simpleReverseProxy :: Manager -> ReverseProxyConfig -> Wai.Application-simpleReverseProxy mgr rpConfig request sendResponse = bracket-    (NHC.responseOpen proxiedRequest mgr)-    responseClose-    $ \res -> sendResponse $ Wai.responseStream-        (responseStatus res)-        (rewriteHeaders respRuleMap $ responseHeaders res)-        (sendBody $ responseBody res)-  where-    proxiedRequest = mkRequest rpConfig request-    respRuleMap = mkRuleMap $ rewriteResponseRules rpConfig-    sendBody body send _flush = fix $ \loop -> do-        bs <- body-        unless (S.null bs) $ do-            () <- send $ fromByteString bs-            loop--data ReverseProxyConfig = ReverseProxyConfig-    { reversedHost :: Text-    , reversedPort :: Int-    , reversedUseSSL :: Bool-    , reversingHost :: Text-    , reversingUseSSL :: !SSLConfig-    , reverseTimeout :: Maybe Int-    , rewriteResponseRules :: Set RewriteRule-    , rewriteRequestRules :: Set RewriteRule-    } deriving (Eq, Ord, Show)--instance FromJSON ReverseProxyConfig where-    parseJSON (Object o) = ReverseProxyConfig-        <$> o .: "reversed-host"-        <*> o .: "reversed-port"-        <*> o .: "reversed-ssl" .!= False-        <*> o .: "reversing-host"-        <*> o .:? "ssl" .!= SSLFalse-        <*> o .:? "timeout" .!= Nothing-        <*> o .:? "rewrite-response" .!= Set.empty-        <*> o .:? "rewrite-request" .!= Set.empty-    parseJSON _ = fail "Wanted an object"--instance ToJSON ReverseProxyConfig where-    toJSON ReverseProxyConfig {..} = object-        [ "reversed-host" .= reversedHost-        , "reversed-port" .= reversedPort-        , "reversed-ssl" .= reversedUseSSL-        , "reversing-host" .= reversingHost-        , "ssl" .= reversingUseSSL-        , "timeout" .= reverseTimeout-        , "rewrite-response" .= rewriteResponseRules-        , "rewrite-request" .= rewriteRequestRules-        ]--instance Default ReverseProxyConfig where-    def = ReverseProxyConfig-        { reversedHost = ""-        , reversedPort = 80-        , reversedUseSSL = False-        , reversingHost = ""-        , reversingUseSSL = SSLFalse-        , reverseTimeout = Nothing-        , rewriteResponseRules = Set.empty-        , rewriteRequestRules = Set.empty-        }--data RewriteRule = RewriteRule-    { ruleHeader :: Text-    , ruleRegex :: Text-    , ruleReplacement :: Text-    } deriving (Eq, Ord, Show)--instance FromJSON RewriteRule where-    parseJSON (Object o) = RewriteRule-        <$> o .: "header"-        <*> o .: "from"-        <*> o .: "to"-    parseJSON _ = fail "Wanted an object"--instance ToJSON RewriteRule where-    toJSON RewriteRule {..} = object-        [ "header" .= ruleHeader-        , "from" .= ruleRegex-        , "to" .= ruleReplacement-        ]

@@ -1,6 +1,6 @@ Cabal-version:       >=1.10 Name:                keter-Version:             1.9+Version:             2.0 Synopsis:            Web application deployment manager, focusing on Haskell web frameworks Description:     Deployment system for web applications, originally intended for hosting Yesod@@ -41,7 +41,6 @@                      , transformers                      , process                   >= 1.4.3         && < 1.7                      , random-                     , data-default                      , filepath                      , zlib                      , network@@ -61,7 +60,7 @@                      , http-types                      , regex-tdfa                >= 1.1                      , attoparsec                >= 0.10-                     , http-client+                     , http-client               >= 0.5.0                      , http-conduit              >= 2.1                      , case-insensitive                      , array@@ -87,11 +86,11 @@     cpp-options:       -DSYSTEM_FILEPATH    Exposed-Modules:     Keter.Plugin.Postgres-                       Keter.Types-                       Keter.Types.V04-                       Keter.Types.V10-                       Keter.Types.Common-                       Keter.Types.Middleware+                       Keter.Config+                       Keter.Config.V04+                       Keter.Config.V10+                       Keter.Common+                       Keter.Config.Middleware                        Keter.App                        Keter.AppManager                        Keter.LabelMap@@ -100,20 +99,21 @@                        Keter.PortPool                        Keter.Proxy                        Keter.HostManager-                       Network.HTTP.ReverseProxy.Rewrite-                       Data.Yaml.FilePath-                       Data.Aeson.KeyHelper-                       Codec.Archive.TempTarball-                       Data.Conduit.LogFile-                       Data.Conduit.Process.Unix+                       Keter.Rewrite+                       Keter.Yaml.FilePath+                       Keter.TempTarball+                       Keter.Conduit.LogFile+                       Keter.Conduit.Process.Unix+  Other-Modules:+                       Keter.Aeson.KeyHelper   ghc-options:         -Wall   c-sources:           cbits/process-tracker.c-+  hs-source-dirs: src Executable keter   default-language:    Haskell98   Main-is:             keter.hs-  hs-source-dirs:      main-  Build-depends:       base, keter, data-default, filepath+  hs-source-dirs:      src/main+  Build-depends:       base, keter, filepath   ghc-options:         -threaded -Wall   other-modules:       Paths_keter @@ -126,8 +126,9 @@                    , transformers                    , conduit                    , bytestring-                   , hspec >= 1.3                    , unix+                   , tasty+                   , tasty-hunit                    , keter                    , HUnit     ghc-options:     -Wall -threaded

@@ -1,26 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-import Prelude (error, (++), ($), IO, putStrLn)-import System.Environment (getArgs, getProgName)-import Keter.Main (keter)-import Paths_keter (version)-import Data.Version (showVersion)-import qualified Keter.Plugin.Postgres as Postgres-import Data.Default (def)-import System.FilePath ((</>))--main :: IO ()-main = do-    args <- getArgs-    case args of-        ["--version"] -> putStrLn $ "keter version: " ++ showVersion version-        ["--help"] -> printUsage-        [dir] -> keter-            dir-            [\configDir -> Postgres.load def $ configDir </> "etc" </> "postgres.yaml"]-        _ -> printUsage--printUsage :: IO ()-printUsage = do-    pn <- getProgName-    error $ "Usage: " ++ pn ++ " <config file>"

@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+-- | Utilities for dealing with Aeson version update++module Keter.Aeson.KeyHelper+  ( module KeyMap+  , toKey+  , toText+  ) where++import Prelude (id)+import qualified Data.Text                   as Text++#if MIN_VERSION_aeson (2,0,0)+import qualified Data.Aeson.Key              as Key+import Data.Aeson.KeyMap                     as KeyMap hiding (map)++toKey :: Text.Text -> Key.Key+toKey = Key.fromText++toText :: Key.Key -> Text.Text+toText = Key.toText++#else+import Data.HashMap.Strict                   as KeyMap hiding (map)++toKey :: Text.Text -> Text.Text+toKey = id++toText :: Text.Text -> Text.Text+toText = id++#endif

@@ -0,0 +1,734 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE NamedFieldPuns      #-}++module Keter.App+    ( App+    , AppStartConfig (..)+    , start+    , reload+    , getTimestamp+    , Keter.App.terminate+    , showApp+    ) where++import Keter.Common+import           Data.Set                   (Set)+import           Data.Text                  (Text)+import           System.FilePath            (FilePath)+import           Data.Map                   (Map)+import           Keter.Rewrite (ReverseProxyConfig (..))+import           Keter.TempTarball+import           Control.Applicative       ((<$>), (<*>))+import           Control.Arrow             ((***))+import           Control.Concurrent        (forkIO, threadDelay)+import           Control.Concurrent.STM+import           Control.Exception         (IOException, bracketOnError,+                                            throwIO, try, catch)+import           Control.Monad             (void, when, liftM)+import qualified Data.CaseInsensitive      as CI+import           Keter.Conduit.LogFile      (RotatingLog)+import qualified Keter.Conduit.LogFile      as LogFile+import           Keter.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,+                                            monitorProcess,+                                            terminateMonitoredProcess, printStatus)+import           Data.Foldable             (for_, traverse_)+import           Data.IORef+import qualified Data.Map                  as Map+import           Data.Maybe                (fromMaybe)+import           Data.Monoid               ((<>), mempty)+import qualified Data.Set                  as Set+import           Data.Text                 (pack, unpack)+import           Data.Text.Encoding        (decodeUtf8With, encodeUtf8)+import           Data.Text.Encoding.Error  (lenientDecode)+import qualified Data.Vector               as V+import           Data.Yaml+import           Keter.Yaml.FilePath+import System.FilePath ((</>))+import           System.Directory          (canonicalizePath, doesFileExist,+                                            removeDirectoryRecursive)+import           Keter.HostManager         hiding (start)+import           Keter.PortPool            (PortPool, getPort, releasePort)+import           Keter.Config+import           Network.Socket+import           Prelude                   hiding (FilePath)+import           System.Environment        (getEnvironment)+import           System.IO                 (hClose, IOMode(..))+import           System.Posix.Files        (fileAccess)+import           System.Posix.Types        (EpochTime, GroupID, UserID)+import           System.Timeout            (timeout)+import qualified Network.TLS as TLS++data App = App+    { appModTime        :: !(TVar (Maybe EpochTime))+    , appRunningWebApps :: !(TVar [RunningWebApp])+    , appBackgroundApps :: !(TVar [RunningBackgroundApp])+    , appId             :: !AppId+    , appHosts          :: !(TVar (Set Host))+    , appDir            :: !(TVar (Maybe FilePath))+    , appAsc            :: !AppStartConfig+    , appRlog           :: !(TVar (Maybe RotatingLog))+    }+instance Show App where+  show App {appId, ..} = "App{appId=" <> show appId <> "}"++-- | within an stm context we can show a lot more then the show instance can do+showApp :: App -> STM Text+showApp App{..} = do+  appModTime' <- readTVar appModTime+  appRunning' <- readTVar appRunningWebApps+  appHosts'   <- readTVar appHosts+  pure $ pack $+    (show appId) <>+    " modtime: " <> (show appModTime') <>  ", webappsRunning: " <>  show appRunning' <> ", hosts: " <> show appHosts'+++data RunningWebApp = RunningWebApp+    { rwaProcess            :: !MonitoredProcess+    , rwaPort               :: !Port+    , rwaEnsureAliveTimeOut :: !Int+    }++instance Show RunningWebApp where+  show (RunningWebApp {..})  = "RunningWebApp{rwaPort=" <> show rwaPort <> ", rwaEnsureAliveTimeOut=" <> show rwaEnsureAliveTimeOut <> ",..}"++newtype RunningBackgroundApp = RunningBackgroundApp+    { rbaProcess :: MonitoredProcess+    }++unpackBundle :: AppStartConfig+             -> FilePath+             -> AppId+             -> IO (FilePath, BundleConfig)+unpackBundle AppStartConfig {..} bundle aid = do+    ascLog $ UnpackingBundle bundle+    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+            let yml = dir </> "config" </> "keter.yml"+            exists <- doesFileExist yml+            return $ if exists then yml+                               else dir </> "config" </> "keter.yaml"++        mconfig <- decodeFileRelative configFP+        config <-+            case mconfig of+                Right config -> return config+                Left e -> throwIO $ InvalidConfigFile e+        return (dir, config)+  where+    folderName =+        case aid of+            AIBuiltin -> "__builtin__"+            AINamed x -> x++data AppStartConfig = AppStartConfig+    { ascTempFolder     :: !TempFolder+    , ascSetuid         :: !(Maybe (Text, (UserID, GroupID)))+    , ascProcessTracker :: !ProcessTracker+    , ascHostManager    :: !HostManager+    , ascPortPool       :: !PortPool+    , ascPlugins        :: !Plugins+    , ascLog            :: !(LogMessage -> IO ())+    , ascKeterConfig    :: !KeterConfig+    }++withConfig :: AppStartConfig+           -> 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)++withReservations :: AppStartConfig+                 -> 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)++withActions :: AppStartConfig+            -> BundleConfig+            -> ([ WebAppConfig Port] -> [BackgroundConfig] -> Map Host (ProxyAction, TLS.Credentials) -> IO a)+            -> IO a+withActions asc bconfig f =+    loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty+  where+    -- todo: add loading from relative location+    loadCert (SSL certFile chainCertFiles keyFile) =+         either (const mempty) (TLS.Credentials . (:[]))+            <$> TLS.credentialLoadX509Chain certFile (V.toList chainCertFiles) keyFile+    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))+      where+        hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)+    loop (Stanza (StanzaStaticFiles sfc) rs:stanzas) wacs backs actions0 = do+        cert <- loadCert $ sfconfigSsl sfc+        loop stanzas wacs backs (actions cert)+      where+        actions cert = Map.unions+                $ actions0+                : 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+        loop stanzas wacs backs (actions cert)+      where+        actions cert = Map.unions+                $ actions0+                : 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+        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+  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+    f+  where+    go (Stanza (StanzaWebApp WebAppConfig {..}) _) = do+      isExec waconfigExec+      for_ waconfigEnsureAliveTimeout+        $ \x -> when (x < 1) $ throwIO $ EnsureAliveShouldBeBiggerThenZero x+    go (Stanza (StanzaBackground BackgroundConfig {..}) _) = isExec bgconfigExec+    go _ = return ()++    isExec fp = do+        exists <- doesFileExist fp+        if exists+            then do+                canExec <- fileAccess fp True False True+                if canExec+                    then return ()+                    else throwIO $ FileNotExecutable fp+            else throwIO $ ExecutableNotFound fp++start :: AppStartConfig+      -> 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+            <$> newTVarIO mmodtime+            <*> newTVarIO runningWebapps+            <*> newTVarIO runningBacks+            <*> return aid+            <*> newTVarIO (Map.keysSet actions)+            <*> newTVarIO newdir+            <*> return asc+            <*> return trlog++bracketedMap :: (a -> (b -> IO c) -> IO c)+             -> ([b] -> IO c)+             -> [a]+             -> IO c+bracketedMap with inside =+    loop id+  where+    loop front [] = inside $ front []+    loop front (c:cs) = with c $ \x -> loop (front . (x:)) cs++withWebApps :: AppStartConfig+            -> AppId+            -> BundleConfig+            -> Maybe FilePath+            -> RotatingLog+            -> [WebAppConfig Port]+            -> ([RunningWebApp] -> IO a)+            -> IO a+withWebApps asc aid bconfig mdir rlog configs0 f =+    bracketedMap alloc f configs0+  where+    alloc = launchWebApp asc aid bconfig mdir rlog++launchWebApp :: AppStartConfig+             -> AppId+             -> BundleConfig+             -> Maybe FilePath+             -> RotatingLog+             -> WebAppConfig Port+             -> (RunningWebApp -> IO a)+             -> IO a+launchWebApp AppStartConfig {..} aid BundleConfig {..} mdir rlog WebAppConfig {..} f = do+    otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins+    forwardedEnv <- getForwardedEnv waconfigForwardEnv+    let httpPort  = kconfigExternalHttpPort  ascKeterConfig+        httpsPort = kconfigExternalHttpsPort ascKeterConfig+        (scheme, extport) =+            if waconfigSsl == SSLFalse+                then ("http://",  if httpPort  ==  80 then "" else ':' : show httpPort)+                else ("https://", if httpsPort == 443 then "" else ':' : show httpsPort)+        env = Map.toList $ Map.unions+            -- Ordering chosen specifically to precedence rules: app specific,+            -- plugins, global, and then auto-set Keter variables.+            [ waconfigEnvironment+            , forwardedEnv+            , Map.fromList otherEnv+            , kconfigEnvironment ascKeterConfig+            , Map.singleton "PORT" $ pack $ show waconfigPort+            , Map.singleton "APPROOT" $ scheme <> CI.original waconfigApprootHost <> pack extport+            ]+    exec <- canonicalizePath waconfigExec+    bracketOnError+        (monitorProcess+            (ascLog . OtherMessage . decodeUtf8With lenientDecode)+            ascProcessTracker+            (encodeUtf8 . fst <$> ascSetuid)+            (encodeUtf8 $ pack exec)+            (maybe "/tmp" (encodeUtf8 . pack) mdir)+            (map encodeUtf8 $ V.toList waconfigArgs)+            (map (encodeUtf8 *** encodeUtf8) env)+            (LogFile.addChunk rlog)+            (const $ return True))+        terminateMonitoredProcess+        $ \mp -> f RunningWebApp+            { rwaProcess = mp+            , rwaPort = waconfigPort+            , rwaEnsureAliveTimeOut = fromMaybe (90 * 1000 * 1000) waconfigEnsureAliveTimeout+            }+  where+    name =+        case aid of+            AIBuiltin -> "__builtin__"+            AINamed x -> x++killWebApp :: (LogMessage -> IO ()) -> RunningWebApp -> IO ()+killWebApp asclog RunningWebApp {..} = do+    status <- printStatus rwaProcess+    asclog $ KillingApp rwaPort status+    terminateMonitoredProcess rwaProcess++ensureAlive :: RunningWebApp -> IO ()+ensureAlive RunningWebApp {..} = do+    didAnswer <- testApp rwaPort+    if didAnswer+        then return ()+        else error $ "ensureAlive failed, this means keter couldn't " <>+                      "detect your app at port " <> show rwaPort <>+                      ", check your app logs detailed errors. " <>+                      " Also make sure your app binds to the PORT environment variable (not YESOD_PORT for example)." -- TODO domain name would be good to add as well+  where+    testApp :: Port -> IO Bool+    testApp port = do+        res <- timeout rwaEnsureAliveTimeOut testApp'+        return $ fromMaybe False res+      where+        testApp' = do+            threadDelay $ 2 * 1000 * 1000+            eres <- try $ connectTo "127.0.0.1" $ show port+            case eres of+                Left (_ :: IOException) -> testApp'+                Right handle -> do+                    hClose handle+                    return True+        connectTo host serv = do+            let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]+                                     , addrSocketType = Stream }+            addrs <- getAddrInfo (Just hints) (Just host) (Just serv)+            firstSuccessful $ map tryToConnect addrs+            where+              tryToConnect addr =+                bracketOnError+                  (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))+                  (close)  -- only done if there's an error+                  (\sock -> do+                    connect sock (addrAddress addr)+                    socketToHandle sock ReadWriteMode+                  )+              firstSuccessful = go Nothing+                where+                  go _ (p:ps) = do+                    r <- tryIO p+                    case r of+                          Right x -> return x+                          Left  e -> go (Just e) ps+                 -- All operations failed, throw error if one exists+                  go Nothing  [] = ioError $ userError $ "connectTo firstSuccessful: empty list"+                  go (Just e) [] = throwIO e+                  tryIO :: IO a -> IO (Either IOException a)+                  tryIO m = catch (liftM Right m) (return . Left)+++withBackgroundApps :: AppStartConfig+                   -> AppId+                   -> BundleConfig+                   -> Maybe FilePath+                   -> RotatingLog+                   -> [BackgroundConfig]+                   -> ([RunningBackgroundApp] -> IO a)+                   -> IO a+withBackgroundApps asc aid bconfig mdir rlog configs f =+    bracketedMap alloc f configs+  where+    alloc = launchBackgroundApp asc aid bconfig mdir rlog++launchBackgroundApp :: AppStartConfig+                    -> AppId+                    -> BundleConfig+                    -> Maybe FilePath+                    -> RotatingLog+                    -> BackgroundConfig+                    -> (RunningBackgroundApp -> IO a)+                    -> IO a+launchBackgroundApp AppStartConfig {..} aid BundleConfig {..} mdir rlog BackgroundConfig {..} f = do+    otherEnv <- pluginsGetEnv ascPlugins name bconfigPlugins+    forwardedEnv <- getForwardedEnv bgconfigForwardEnv+    let env = Map.toList $ Map.unions+            -- Order matters as in launchWebApp+            [ bgconfigEnvironment+            , forwardedEnv+            , Map.fromList otherEnv+            , kconfigEnvironment ascKeterConfig+            ]+    exec <- canonicalizePath bgconfigExec++    let delay = threadDelay $ fromIntegral $ bgconfigRestartDelaySeconds * 1000 * 1000+    shouldRestart <-+        case bgconfigRestartCount of+            UnlimitedRestarts -> return $ do+                delay+                return True+            LimitedRestarts maxCount -> do+                icount <- newIORef 0+                return $ do+                    res <- atomicModifyIORef icount $ \count ->+                        (count + 1, count < maxCount)+                    when res delay+                    return res++    bracketOnError+        (monitorProcess+            (ascLog . OtherMessage . decodeUtf8With lenientDecode)+            ascProcessTracker+            (encodeUtf8 . fst <$> ascSetuid)+            (encodeUtf8 $ pack exec)+            (maybe "/tmp" (encodeUtf8 . pack) mdir)+            (map encodeUtf8 $ V.toList bgconfigArgs)+            (map (encodeUtf8 *** encodeUtf8) env)+            (LogFile.addChunk rlog)+            (const shouldRestart))+        terminateMonitoredProcess+        (f . RunningBackgroundApp)+  where+    name =+        case aid of+            AIBuiltin -> "__builtin__"+            AINamed x -> x++killBackgroundApp :: RunningBackgroundApp -> IO ()+killBackgroundApp RunningBackgroundApp {..} = do+    terminateMonitoredProcess rbaProcess++    {-+start :: TempFolder+      -> Maybe (Text, (UserID, GroupID))+      -> ProcessTracker+      -> HostManager+      -> Plugins+      -> RotatingLog+      -> Appname+      -> (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+    Prelude.error "FIXME Keter.App.start"+    chan <- newChan+    return (App $ writeChan chan, rest chan)+  where++    rest chan = forkKIO $ do+        mres <- unpackBundle tf (snd <$> muid) bundle appname+        case mres of+            Left e -> do+                $logEx e+                removeFromList+            Right (dir, config) -> do+                let common = do+                        mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ bconfigStaticHosts config+                        mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ bconfigRedirects config+                case bconfigApp config of+                    Nothing -> do+                        common+                        loop chan dir config Nothing+                    Just appconfig -> do+                        eport <- getPort portman+                        case eport of+                            Left e -> do+                                $logEx e+                                removeFromList+                            Right port -> do+                                eprocess <- runApp port dir appconfig+                                case eprocess of+                                    Left e -> do+                                        $logEx e+                                        removeFromList+                                    Right process -> do+                                        b <- testApp port+                                        if b+                                            then do+                                                addEntry portman (aconfigHost appconfig) $ PEPort port+                                                mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig+                                                common+                                                loop chan dir config $ Just (process, port)+                                            else do+                                                removeFromList+                                                releasePort portman port+                                                void $ liftIO $ terminateMonitoredProcess process++    loop chan dirOld configOld mprocPortOld = do+        command <- readChan chan+        case command of+            Terminate -> do+                removeFromList+                case bconfigApp configOld of+                    Nothing -> return ()+                    Just appconfig -> do+                        removeEntry portman $ aconfigHost appconfig+                        mapM_ (removeEntry portman) $ Set.toList $ aconfigExtraHosts appconfig+                mapM_ (removeEntry portman) $ map shHost $ Set.toList $ bconfigStaticHosts configOld+                mapM_ (removeEntry portman) $ map redFrom $ Set.toList $ bconfigRedirects configOld+                log $ TerminatingApp appname+                terminateOld+            Reload -> do+                mres <- unpackBundle tf (snd <$> muid) bundle appname+                case mres of+                    Left e -> do+                        log $ InvalidBundle bundle e+                        loop chan dirOld configOld mprocPortOld+                    Right (dir, config) -> do+                        eport <- getPort portman+                        case eport of+                            Left e -> $logEx e+                            Right port -> do+                                let common = do+                                        mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ bconfigStaticHosts config+                                        mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ bconfigRedirects config+                                case bconfigApp config of+                                    Nothing -> do+                                        common+                                        loop chan dir config Nothing+                                    Just appconfig -> do+                                        eprocess <- runApp port dir appconfig+                                        mprocess <-+                                            case eprocess of+                                                Left _ -> return Nothing+                                                Right process -> do+                                                    b <- testApp port+                                                    return $ if b+                                                        then Just process+                                                        else Nothing+                                        case mprocess of+                                            Just process -> do+                                                addEntry portman (aconfigHost appconfig) $ PEPort port+                                                mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig+                                                common+                                                case bconfigApp configOld of+                                                    Just appconfigOld | aconfigHost appconfig /= aconfigHost appconfigOld ->+                                                        removeEntry portman $ aconfigHost appconfigOld+                                                    _ -> return ()+                                                log $ FinishedReloading appname+                                                terminateOld+                                                loop chan dir config $ Just (process, port)+                                            Nothing -> do+                                                releasePort portman port+                                                case eprocess of+                                                    Left _ -> return ()+                                                    Right process -> void $ liftIO $ terminateMonitoredProcess process+                                                log $ ProcessDidNotStart bundle+                                                loop chan dirOld configOld mprocPortOld+      where+        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++            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++terminate :: App -> IO ()+terminate App {..} = do+    (hosts, apps, backs, mdir, rlog) <- atomically $ do+        hosts <- readTVar appHosts+        apps <- readTVar appRunningWebApps+        backs <- readTVar appBackgroundApps+        mdir <- readTVar appDir+        rlog <- readTVar appRlog++        writeTVar appModTime Nothing+        writeTVar appRunningWebApps []+        writeTVar appBackgroundApps []+        writeTVar appHosts Set.empty+        writeTVar appDir Nothing+        writeTVar appRlog Nothing++        return (hosts, apps, backs, mdir, rlog)++    deactivateApp ascLog ascHostManager appId hosts+    void $ forkIO $ terminateHelper appAsc appId apps backs mdir rlog+    maybe (return ()) LogFile.close rlog+  where+    AppStartConfig {..} = appAsc++terminateHelper :: AppStartConfig+                -> 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+    case mdir of+        Nothing -> return ()+        Just dir -> do+            ascLog $ RemovingOldFolder dir+            res <- try $ removeDirectoryRecursive dir+            case res of+                Left e -> $logEx ascLog e+                Right () -> return ()++-- | Get the modification time of the bundle file this app was launched from,+-- if relevant.+getTimestamp :: App -> STM (Maybe EpochTime)+getTimestamp = readTVar . appModTime++pluginsGetEnv :: Plugins -> Appname -> Object -> IO [(Text, Text)]+pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps++-- | For the forward-env option. From a Set of desired variables, create a+-- Map pulled from the system environment.+getForwardedEnv :: Set Text -> IO (Map Text Text)+getForwardedEnv vars = filterEnv <$> getEnvironment+  where+    filterEnv = Map.filterWithKey (\k _ -> Set.member k vars)+              . Map.fromList+              . map (pack *** pack)+++    {- FIXME handle static stanzas+    let staticReverse r = do+            HostMan.addEntry hostman (ReverseProxy.reversingHost r)+                $ HostMan.PEReverseProxy+                $ ReverseProxy.RPEntry r manager+    runKIO' $ mapM_ staticReverse (Set.toList kconfigReverseProxy)+    -}++{- FIXME+            rest <-+                case Map.lookup appname appMap of+                    Just (app, _time) -> do+                        App.reload app+                        etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)+                        let time = either (P.const 0) id etime+                        return (Map.insert appname (app, time) appMap, return ())+                    Nothing -> do+                        mlogger <- do+                            let dirout = kconfigDir </> "log" </> fromText ("app-" ++ appname)+                                direrr = dirout </> "err"+                            erlog <- liftIO $ LogFile.openRotatingLog+                                (F.encodeString dirout)+                                LogFile.defaultMaxTotal+                            case erlog of+                                Left e -> do+                                    $logEx e+                                    return Nothing+                                Right rlog -> return (Just rlog)+                        let logger = fromMaybe LogFile.dummy mlogger+                        (app, rest) <- App.start+                            tf+                            muid+                            processTracker+                            hostman+                            plugins+                            logger+                            appname+                            bundle+                            (removeApp appname)+                        etime <- liftIO $ modificationTime <$> getFileStatus (F.encodeString bundle)+                        let time = either (P.const 0) id etime+                        let appMap' = Map.insert appname (app, time) appMap+                        return (appMap', rest)+            rest+            -}

@@ -0,0 +1,290 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE RecordWildCards   #-}+-- | Used for management of applications.+module Keter.AppManager+    ( -- * Types+      AppManager+    , Action (..)+      -- * Actions+    , perform+    , reloadAppList+    , addApp+    , terminateApp+      -- * Initialize+    , initialize+      -- * Show+    , renderApps+    ) where++import Keter.Common+import           Data.Set                   (Set)+import           Data.Text                  (Text)+import           System.FilePath            (FilePath)+import           Data.Map                   (Map)+import           Control.Exception          (SomeException)+import           Control.Applicative+import           Control.Concurrent         (forkIO)+import           Control.Concurrent.MVar    (MVar, newMVar, withMVar)+import           Control.Concurrent.STM+import qualified Control.Exception          as E+import           Control.Monad              (void)+import           Data.Foldable              (fold)+import qualified Data.Map                   as Map+import           Data.Maybe                 (catMaybes, mapMaybe)+import qualified Data.Set                   as Set+import           Data.Text                  (pack, unpack)+import qualified Data.Text.Lazy             as LT+import qualified Data.Text.Lazy.Builder     as Builder+import           Data.Traversable.WithIndex (itraverse)+import           Keter.App                  (App, AppStartConfig, showApp)+import qualified Keter.App                  as App+import           Keter.Config+import           Prelude                    hiding (FilePath, log)+import           System.Posix.Files         (getFileStatus, modificationTime)+import           System.Posix.Types         (EpochTime)+import           Text.Printf                (printf)++data AppManager = AppManager+    { apps           :: !(TVar (Map AppId (TVar AppState)))+    , appStartConfig :: !AppStartConfig+    , mutex          :: !(MVar ())+    , log            :: !(LogMessage -> IO ())+    }++data AppState = ASRunning App+              | ASStarting+                    !(Maybe App)+                    !(TVar (Maybe EpochTime))+                    !(TVar (Maybe Action)) -- ^ the next one to try+              | ASTerminated++showAppState :: AppState -> STM Text+showAppState (ASRunning x) = (\x -> "running(" <> x <> ")") <$> showApp x+showAppState (ASStarting mapp tmtime tmaction) = do+  mtime   <- readTVar tmtime+  maction <- readTVar tmaction+  mtext <- traverse showApp mapp+  pure $ pack $ printf "starting app %s, time %s, action %s \n" (unpack $ fold mtext) (show mtime) (show maction)+showAppState ASTerminated = pure "terminated"++renderApps :: AppManager -> STM Text+renderApps mngr = do+  appMap <- readTVar $ apps mngr+  x <- itraverse (\appId tappState -> do+                state <- readTVar tappState+                res <- showAppState state+                pure $ Builder.fromText $ res <> " \n"+               ) appMap+  pure $ LT.toStrict $ Builder.toLazyText $ fold x++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'++-- | Reset which apps are running.+--+-- * Any app not listed here that is currently running will be terminated.+--+-- * 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+  where+    toAppName AIBuiltin   = Nothing+    toAppName (AINamed x) = Just x++    getAction currentApps appname = do+        case Map.lookup (AINamed appname) currentApps of+            Nothing -> return freshLaunch+            Just tstate -> do+                state <- readTVar tstate+                case state of+                    ASTerminated -> return freshLaunch+                    ASRunning app ->+                        case Map.lookup appname newApps of+                            Nothing -> return terminate+                            Just (fp, newTimestamp) -> do+                                moldTimestamp <- App.getTimestamp app+                                return $ if moldTimestamp == Just newTimestamp+                                    then Nothing+                                    else reload fp newTimestamp+                    ASStarting _ tmoldTimestamp tmaction ->+                        case Map.lookup appname newApps of+                            Nothing -> do+                                writeTVar tmaction $ Just Terminate+                                return Nothing+                            Just (fp, newTimestamp) -> do+                                moldTimestamp <- readTVar tmoldTimestamp+                                return $ if moldTimestamp == Just newTimestamp+                                    then Nothing+                                    else reload fp newTimestamp+      where+        freshLaunch =+            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)+        {-+        case (Map.lookup appname currentApps, Map.lookup appname newApps) of+            (Nothing, Nothing) -> E.assert False Nothing+            (Just _, Nothing) -> Just $ perform am (AINamed appname) Terminate+            (Nothing, Just _) -> Just $ perform am (AINamed appname) (Reload AIBundle)+            -}++    {- FIXME+        actions <- do++            current <- getAllApps appMan+            let apps = Set.toList $ Set.fromList (Map.keys newMap) `Set.union` current+            fmap catMaybes $ forM apps $ \appname -> return $+                case (Set.member appname current, Map.lookup appname newMap) of+                    (False, Nothing) -> Nothing -- should never happen+                    (True, Nothing) -> Just $ terminateApp appname+                    (False, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle+                    (Just (_, oldTime), Just (bundle, newTime))+                        | newTime /= oldTime -> Just $ runKIO' $ addApp bundle+                        | otherwise -> Nothing+        P.sequence_ actions++getAllApps :: AppManager -> IO (Set Appname)+getAllApps AppManager {..} = atomically $ do+    m <- readTVar apps+    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++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'+  where+    noWorker = return ()++    onNotRunning =+        case action of+            Reload input -> do+                tmnext <- newTVar Nothing+                tmtimestamp <- newTVar $+                    case input of+                        AIBundle _fp timestamp -> Just timestamp+                        AIData _               -> Nothing+                tstate <- newTVar $ ASStarting Nothing tmtimestamp tmnext+                modifyTVar apps $ Map.insert aid tstate+                return $ launchWorker am aid tstate tmnext Nothing action+            Terminate -> return noWorker++launchWorker :: AppManager+             -> AppId+             -> TVar AppState+             -> TVar (Maybe Action)+             -> Maybe App+             -> Action+             -> IO ()+launchWorker AppManager {..} appid tstate tmnext mcurrentApp0 action0 = void $ forkIO $ do+    loop mcurrentApp0 action0+  where+    loop mcurrentApp action = do+        mRunningApp <- processAction mcurrentApp action+        mnext <- atomically $ do+            mnext <- readTVar tmnext+            writeTVar tmnext Nothing+            case mnext of+                Nothing ->+                    case mRunningApp of+                        Nothing -> writeTVar tstate ASTerminated+                        Just runningApp -> writeTVar tstate $ ASRunning runningApp+                Just _next -> do+                    tmtimestamp <- newTVar $+                        case action of+                            Reload (AIBundle _fp timestamp) -> Just timestamp+                            Reload (AIData _)               -> Nothing+                            Terminate                       -> Nothing+                    writeTVar tstate $ ASStarting mRunningApp tmtimestamp tmnext+            return mnext+        case mnext of+            Nothing   -> return ()+            Just next -> loop mRunningApp next++    processAction Nothing Terminate = return Nothing+    processAction (Just app) Terminate = do+        log $ Terminating $ show app+        App.terminate app+        return Nothing+    processAction Nothing (Reload input) = do+        log $ ReloadFrom Nothing $ show input+        eres <- E.try $ App.start appStartConfig appid input+        case eres of+            Left e -> do+                log $ ErrorStartingBundle name 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+        case eres of+            Left e -> do+                log $ ErrorStartingBundle name 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)+            Right () -> return $ Just app++    name =+        case appid of+            AIBuiltin -> "<builtin>"+            AINamed x -> x++addApp :: AppManager -> FilePath -> IO ()+addApp appMan bundle = do+    (input, action) <- getInputForBundle bundle+    perform appMan 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+

@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}+module Keter.Cli+    ( launchCli+    , CliStates(..)+    ) where++import Keter.Common+import Keter.AppManager+import Control.Concurrent (forkFinally)+import qualified Control.Exception as E+import Control.Monad (unless, forever, void, when)+import qualified Data.ByteString as S+import Network.Socket+import Network.Socket.ByteString (recv, sendAll)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Options.Applicative+import Data.Foldable+import GHC.Conc++data Commands = CmdListRunningApps+              | CmdExit++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+commandParser :: Parser Commands+commandParser = hsubparser $+  fold [+  command "exit"+    (info (pure CmdExit)+      (progDesc "List all ports"))+  ,+  command "apps"+      (info (pure CmdListRunningApps)+        (progDesc "Exit the program"))+  ]++resolve :: ServiceName -> IO AddrInfo+resolve port = do+        let hints = defaultHints {+                addrFlags = [AI_PASSIVE]+              , addrSocketType = Stream+              }+        addr:_ <- getAddrInfo (Just hints) Nothing (Just port)+        return addr++open :: AddrInfo -> IO Socket+open addr = do+    sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+    setSocketOption sock ReuseAddr 1+    -- If the prefork technique is not used,+    -- set CloseOnExec for the security reasons.+    withFdSocket sock $ setCloseOnExecIfNeeded+    bind sock (addrAddress addr)+    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)++listRunningApps :: CliStates -> Socket -> IO ()+listRunningApps states conn = do+  txt <- atomically $ renderApps $ csAppManager states+  sendAll conn $ T.encodeUtf8 txt <> "\n"++talk :: CliStates -> Socket -> IO ()+talk states conn = do+    msg <- 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))+        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"+            Failure failure        ->+              True <$ sendAll conn (T.encodeUtf8 (T.pack $ fst $ renderFailure failure "") <> "\n")+          when isLoop $ talk states conn

@@ -0,0 +1,229 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeFamilies       #-}++-- | Provides logging, versioning and some type aliases+module Keter.Common where++import qualified Network.Wai                       as Wai+import           Control.Exception          (Exception, SomeException)+import           Data.Aeson                 (FromJSON, Object, ToJSON,+                                             Value (Bool), object, withBool,+                                             withObject, (.!=), (.:?), (.=))+import           Data.ByteString            (ByteString)+import           Data.CaseInsensitive       (CI, original)+import           Data.Map                   (Map)+import           Data.Set                   (Set)+import qualified Data.Set                   as Set+import           Data.Text                  (Text, pack, unpack)+import           Data.Typeable              (Typeable)+import           Data.Vector                (Vector)+import qualified Data.Vector                as V+import qualified Data.Yaml+import           Keter.Yaml.FilePath+import qualified Language.Haskell.TH.Syntax as TH+import           Network.Socket             (AddrInfo, SockAddr)+import           System.Exit                (ExitCode)+import           System.FilePath            (FilePath, takeBaseName)++-- | Name of the application. Should just be the basename of the application+-- file.+type Appname = Text++data Plugin = Plugin+    { pluginGetEnv :: Appname -> Object -> IO [(Text, Text)]+    }++type Plugins = [Plugin]++-- | Used for versioning data types.+class ToCurrent a where+    type Previous a+    toCurrent :: Previous a -> a+instance ToCurrent a => ToCurrent (Maybe a) where+    type Previous (Maybe a) = Maybe (Previous a)+    toCurrent = fmap toCurrent++-- | A port for an individual app to listen on.+type Port = Int++-- | A virtual host we want to serve content from.+type Host = CI Text++type HostBS = CI ByteString++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+                    | InvalidConfigFile Data.Yaml.ParseException+                    | InvalidKeterConfigFile !FilePath !Data.Yaml.ParseException+                    | CannotReserveHosts !AppId !(Map Host AppId)+                    | FileNotExecutable !FilePath+                    | ExecutableNotFound !FilePath+                    | 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)+instance Show AppId where+    show AIBuiltin   = "/builtin/"+    show (AINamed t) = unpack t++data SSLConfig+    = SSLFalse+    | SSLTrue+    | SSL !FilePath !(Vector FilePath) !FilePath+    deriving (Show, Eq, Ord)++instance ParseYamlFile SSLConfig where+    parseYamlFile _ v@(Bool _) =+        withBool "ssl" ( \b ->+            return (if b then SSLTrue else SSLFalse) ) v+    parseYamlFile basedir v =  withObject "ssl" ( \o -> do+             mcert <- lookupBaseMaybe basedir o "certificate"+             mkey <- lookupBaseMaybe basedir o "key"+             case (mcert, mkey) of+                 (Just cert, Just key) -> do+                     chainCerts <- o .:? "chain-certificates"+                         >>= maybe (return V.empty) (parseYamlFile basedir)+                     return $ SSL cert chainCerts key+                 _ -> return SSLFalse+            ) v++instance ToJSON SSLConfig where+    toJSON SSLTrue = Bool True+    toJSON SSLFalse = Bool False+    toJSON (SSL c cc k) = object [ "certificate" .= c+                                 , "chain-certificates" .= cc+                                 , "key" .= k+                                 ]+instance FromJSON SSLConfig where+    parseJSON v@(Bool _) = withBool "ssl" ( \b ->+                    return (if b then SSLTrue else SSLFalse) ) v+    parseJSON v = withObject "ssl" ( \o -> do+                    mcert <- o .:? "certificate"+                    mkey <- o .:? "key"+                    case (mcert, mkey) of+                        (Just cert, Just key) -> do+                            chainCerts <- o .:? "chain-certificates" .!= V.empty+                            return $ SSL cert chainCerts key+                        _ -> return SSLFalse -- fail "Must provide both certificate and key files"+                    ) v

@@ -0,0 +1,140 @@+{-# 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

@@ -0,0 +1,351 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE DeriveDataTypeable       #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE ScopedTypeVariables      #-}++module Keter.Conduit.Process.Unix+    ( -- * Process tracking+      -- $processTracker++      -- ** Types+      ProcessTracker+      -- ** Functions+    , initProcessTracker++      -- * Monitored process+    , MonitoredProcess+    , monitorProcess+    , terminateMonitoredProcess+    , printStatus+    ) where++import           Data.Text(Text, pack)+import           Control.Applicative             ((<$>), (<*>), pure)+import           Control.Arrow                   ((***))+import           Control.Concurrent              (forkIO)+import           Control.Concurrent              (threadDelay)+import           Control.Concurrent.MVar         (MVar, modifyMVar, modifyMVar_,+                                                  newEmptyMVar, newMVar,+                                                  putMVar, readMVar, swapMVar,+                                                  takeMVar, tryReadMVar)+import           Control.Exception               (Exception, SomeException,+                                                  bracketOnError, finally,+                                                  handle, mask_,+                                                  throwIO, try)+import           Control.Monad                   (void)+import           Data.ByteString                 (ByteString)+import qualified Data.ByteString.Char8           as S8+import           Data.Conduit                    (ConduitM, (.|), runConduit)+import           Data.Conduit.Binary             (sinkHandle, sourceHandle)+import qualified Data.Conduit.List               as CL+import           Data.IORef                      (IORef, newIORef, readIORef,+                                                  writeIORef)+import           Data.Time                       (getCurrentTime)+import           Data.Time                       (diffUTCTime)+import           Data.Typeable                   (Typeable)+import           Foreign.C.Types+import           Prelude                         (Bool (..), Either (..), IO,+                                                  Maybe (..), Monad (..), Show,+                                                  const, error,+                                                  map, maybe, show,+                                                  ($), ($!), (*), (<),+                                                  (==))+import           System.Exit                     (ExitCode)+import           System.IO                       (hClose)+import           System.Posix.IO.ByteString      ( closeFd, createPipe,+                                                  fdToHandle)+import           System.Posix.Signals            (sigKILL, signalProcess)+import           System.Posix.Types              (CPid (..))+import           System.Process                  (CmdSpec (..), CreateProcess (..),+                                                  StdStream (..), createProcess,+                                                  terminateProcess, waitForProcess,+                                                  getPid)+import           System.Process.Internals        (ProcessHandle (..),+                                                  ProcessHandle__ (..))+import Data.Monoid ((<>)) -- sauron++processHandleMVar :: ProcessHandle -> MVar ProcessHandle__+#if MIN_VERSION_process(1, 6, 0)+processHandleMVar (ProcessHandle m _ _) = m+#elif MIN_VERSION_process(1, 2, 0)+processHandleMVar (ProcessHandle m _) = m+#else+processHandleMVar (ProcessHandle m) = m+#endif++withProcessHandle_+        :: ProcessHandle+        -> (ProcessHandle__ -> IO ProcessHandle__)+        -> IO ()+withProcessHandle_ ph io = modifyMVar_ (processHandleMVar ph) io++-- | Kill a process by sending it the KILL (9) signal.+--+-- Since 0.1.0+killProcess :: ProcessHandle -> IO ()+killProcess ph = withProcessHandle_ ph $ \p_ ->+    case p_ of+        ClosedHandle _ -> return p_+        OpenHandle h -> do+            signalProcess sigKILL h+            return p_++ignoreExceptions :: IO () -> IO ()+ignoreExceptions = handle (\(_ :: SomeException) -> return ())++-- $processTracker+--+-- Ensure that child processes are killed, regardless of how the parent process exits.+--+-- The technique used here is:+--+-- * Create a pipe.+--+-- * Fork a new child process that listens on the pipe.+--+-- * In the current process, send updates about processes that should be auto-killed.+--+-- * When the parent process dies, listening on the pipe in the child process will get an EOF.+--+-- * When the child process receives that EOF, it kills all processes it was told to auto-kill.+--+-- This code was originally written for Keter, but was moved to unix-process+-- conduit in the 0.2.1 release.++foreign import ccall unsafe "launch_process_tracker"+    c_launch_process_tracker :: IO CInt++foreign import ccall unsafe "track_process"+    c_track_process :: ProcessTracker -> CPid -> CInt -> IO ()++-- | Represents the child process which handles process cleanup.+--+-- Since 0.2.1+newtype ProcessTracker = ProcessTracker CInt++-- | Represents a child process which is currently being tracked by the cleanup+-- child process.+--+-- Since 0.2.1+data TrackedProcess = TrackedProcess !ProcessTracker !(IORef MaybePid) !(IO ExitCode)++data MaybePid = NoPid | Pid !CPid++-- | Fork off the child cleanup process.+--+-- This will ideally only be run once for your entire application.+--+-- Since 0.2.1+initProcessTracker :: IO ProcessTracker+initProcessTracker = do+    i <- c_launch_process_tracker+    if i == -1+        then throwIO CannotLaunchProcessTracker+        else return $! ProcessTracker i++-- | Since 0.2.1+data ProcessTrackerException = CannotLaunchProcessTracker+    deriving (Show, Typeable)+instance Exception ProcessTrackerException++-- | Begin tracking the given process. If the 'ProcessHandle' refers to a+-- closed process, no tracking will occur. If the process is closed, then it+-- will be untracked automatically.+--+-- Note that you /must/ compile your program with @-threaded@; see+-- 'waitForProcess'.+--+-- Since 0.2.1+trackProcess :: ProcessTracker -> ProcessHandle -> IO TrackedProcess+trackProcess pt ph = mask_ $ do+    mpid <- readMVar $ processHandleMVar ph+    mpid' <- case mpid of+        ClosedHandle{} -> return NoPid+        OpenHandle pid -> do+            c_track_process pt pid 1+            return $ Pid pid+    ipid <- newIORef mpid'+    baton <- newEmptyMVar+    let tp = TrackedProcess pt ipid (takeMVar baton)+    case mpid' of+        NoPid -> return ()+        Pid _ -> void $ forkIO $ do+            waitForProcess ph >>= putMVar baton+            untrackProcess tp+    return $! tp++-- | Explicitly remove the given process from the tracked process list in the+-- cleanup process.+--+-- Since 0.2.1+untrackProcess :: TrackedProcess -> IO ()+untrackProcess (TrackedProcess pt ipid _) = mask_ $ do+    mpid <- readIORef ipid+    case mpid of+        NoPid -> return ()+        Pid pid -> do+            c_track_process pt pid 0+            writeIORef ipid NoPid++-- | Fork and execute a subprocess, sending stdout and stderr to the specified+-- rotating log.+--+-- Since 0.2.1+forkExecuteLog :: ByteString -- ^ command+               -> [ByteString] -- ^ args+               -> Maybe [(ByteString, ByteString)] -- ^ environment+               -> Maybe ByteString -- ^ working directory+               -> 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+    setupPipe+    cleanupPipes+    usePipes+  where+    setupPipe = bracketOnError+        createPipe+        (\(x, y) -> closeFd x `finally` closeFd y)+        (\(x, y) -> (,) <$> fdToHandle x <*> fdToHandle y)+    cleanupPipes (x, y) = hClose x `finally` hClose y++    usePipes pipes@(readerH, writerH) = do+        (min, _, _, ph) <- createProcess CreateProcess+            { cmdspec = RawCommand (S8.unpack cmd) (map S8.unpack args)+            , cwd = S8.unpack <$> mwdir+            , env = map (S8.unpack *** S8.unpack) <$> menv+            , std_in = maybe Inherit (const CreatePipe) mstdin+            , std_out = UseHandle writerH+            , std_err = UseHandle writerH+            , close_fds = True+            , create_group = True+#if MIN_VERSION_process(1, 5, 0)+            , use_process_jobs = False+#endif+#if MIN_VERSION_process(1, 2, 0)+            , delegate_ctlc = False+#endif+#if MIN_VERSION_process(1, 3, 0)+            , detach_console = True+            , create_new_console = False+            , new_session = True+#endif+#if MIN_VERSION_process(1, 4, 0)+            , child_group = Nothing+            , child_user = Nothing+#endif+            }+        ignoreExceptions $ addAttachMessage pipes ph+        void $ forkIO $ ignoreExceptions $+            (runConduit $ sourceHandle readerH .| CL.mapM_ rlog) `finally` hClose readerH+        case (min, mstdin) of+            (Just h, Just source) -> void $ forkIO $ ignoreExceptions $+                (runConduit $ source .| sinkHandle h) `finally` hClose h+            (Nothing, Nothing) -> return ()+            _ -> error $ "Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog"+        return ph++    addAttachMessage pipes ph = withProcessHandle_ ph $ \p_ -> do+        now <- getCurrentTime+        case p_ of+            ClosedHandle ec -> do+                rlog $ S8.concat+                    [ "\n\n"+                    , S8.pack $ show now+                    , ": Process immediately died with exit code "+                    , S8.pack $ show ec+                    , "\n\n"+                    ]+                cleanupPipes pipes+            OpenHandle h -> do+                rlog $ S8.concat+                    [ "\n\n"+                    , S8.pack $ show now+                    , ": Attached new process "+                    , S8.pack $ show h+                    , "\n\n"+                    ]+        return p_++data Status = NeedsRestart | NoRestart | Running ProcessHandle++-- | Run the given command, restarting if the process dies.+monitorProcess+    :: (ByteString -> IO ()) -- ^ log+    -> ProcessTracker+    -> Maybe S8.ByteString -- ^ setuid+    -> S8.ByteString -- ^ executable+    -> S8.ByteString -- ^ working directory+    -> [S8.ByteString] -- ^ command line parameter+    -> [(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++-- | Abstract type containing information on a process which will be restarted.+newtype MonitoredProcess = MonitoredProcess (MVar Status)++printStatus :: MonitoredProcess -> IO Text+printStatus (MonitoredProcess mstatus) = do+  mStatus <- tryReadMVar mstatus+  case mStatus of+    Nothing -> pure "no status set process"+    Just NeedsRestart -> pure "needs-restart process"+    Just NoRestart -> pure "no-restart process"+    Just (Running running) -> do+      x <- getPid running+      case x of+        Just y -> pure ("running process '" <> pack (show y) <> "'")+        Nothing -> pure "just closed process"++-- | Terminate the process and prevent it from being restarted.+terminateMonitoredProcess :: MonitoredProcess -> IO ()+terminateMonitoredProcess (MonitoredProcess mstatus) = do+    status <- swapMVar mstatus NoRestart+    case status of+        Running pid -> do+            terminateProcess pid+            threadDelay 1000000+            killProcess pid+        _ -> return ()

@@ -0,0 +1,26 @@+-- | This does a merger of V04 and V10+--   Effectivelly this provides the 'latest' config.+module Keter.Config+    ( module X+    ) where++import Keter.Config.V04 as X (PortSettings (..), TLSConfig (..))+import Keter.Config.V10 as X+    ( BundleConfig (..)+    , WebAppConfig (..)+    , RedirectConfig (..)+    , StaticFilesConfig (..)+    , KeterConfig (..)+    , Stanza (..)+    , StanzaRaw (..)+    , ProxyAction+    , ProxyActionRaw (..)+    , RedirectDest (..)+    , RedirectAction (..)+    , SourcePath (..)+    , ListeningPort (..)+    , AppInput (..)+    , BackgroundConfig (..)+    , RestartCount (..)+    , RequiresSecure+    )

@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}++module Keter.Config.Middleware where++import Data.Aeson+import GHC.Generics+import Prelude+import Network.Wai++import Control.Monad+import Control.Arrow ((***))++-- various Middlewares+import Network.Wai.Middleware.AcceptOverride  (acceptOverride)+import Network.Wai.Middleware.Autohead        (autohead)+import Network.Wai.Middleware.Jsonp           (jsonp)+import Network.Wai.Middleware.Local           (local)+import Network.Wai.Middleware.AddHeaders      (addHeaders)+import Network.Wai.Middleware.MethodOverride  (methodOverride)+import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)+import Network.Wai.Middleware.HttpAuth        (basicAuth)++import Data.ByteString.Lazy         as L (ByteString)+import Data.ByteString  as S (ByteString)++import Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8)+import Data.Text.Encoding as T (encodeUtf8, decodeUtf8)+import Data.String (fromString)+import qualified Keter.Aeson.KeyHelper as AK (toKey, toText, toList, empty)++data MiddlewareConfig = AcceptOverride+                      | Autohead+                      | Jsonp+                      | MethodOverride+                      | MethodOverridePost+                      | AddHeaders ![(S.ByteString, S.ByteString)]+                      | BasicAuth !String ![(S.ByteString, S.ByteString)]+                         -- ^ Realm [(username,password)]+                      | Local !Int !L.ByteString+                         -- ^ Status Message+          deriving (Show,Generic)++instance FromJSON MiddlewareConfig where+  parseJSON (String "accept-override"     ) = pure AcceptOverride+  parseJSON (String "autohead"            ) = pure Autohead+  parseJSON (String "jsonp"               ) = pure Jsonp+  parseJSON (String "method-override"     ) = pure MethodOverride+  parseJSON (String "method-override-post") = pure MethodOverridePost+  parseJSON (Object o) =+     case AK.toList o of+      [("basic-auth", Object ( o'))] -> BasicAuth  <$> o' .:? "realm" .!= "keter"+                                                <*> (map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8) . AK.toList <$> o' .:? "creds"   .!= AK.empty)+      [("headers"   , Object _ )]    -> AddHeaders . map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8) . AK.toList <$> o  .:? "headers" .!= AK.empty+      [("local"     , Object o')] -> Local  <$> o' .:? "status" .!=  401+                                            <*> (TL.encodeUtf8 <$> o' .:? "message" .!= "Unauthorized Accessing from Localhost ONLY" )+      _                      -> mzero -- fail "Rule: unexpected format"+  parseJSON _ = mzero++instance ToJSON MiddlewareConfig where+  toJSON AcceptOverride     = "accept-override"+  toJSON Autohead           = "autohead"+  toJSON Jsonp              = "jsonp"+  toJSON MethodOverride     = "method-override"+  toJSON MethodOverridePost = "method-override-post"+  toJSON (BasicAuth realm cred) = object [ "basic-auth" .= object [ "realm" .= realm+                                                                  , "creds" .= object ( map ( (AK.toKey . T.decodeUtf8) *** (String . T.decodeUtf8)) cred )+                                                                  ]+                                         ]+  toJSON (AddHeaders headers)   = object [ "headers"    .= object ( map ((AK.toKey . T.decodeUtf8) *** String . T.decodeUtf8) headers)  ]+  toJSON (Local sc msg)         = object [ "local"      .= object [ "status" .= sc+                                                                  , "message" .=  TL.decodeUtf8 msg +                                                                  ]+                                         ]+++{-- Still missing+-- CleanPath+-- Gzip+-- RequestLogger+-- Rewrite+-- Vhost+--}++processMiddleware :: [MiddlewareConfig] -> Middleware+processMiddleware = composeMiddleware . map toMiddleware++toMiddleware :: MiddlewareConfig -> Middleware+toMiddleware AcceptOverride     = acceptOverride+toMiddleware Autohead           = autohead+toMiddleware Jsonp              = jsonp+toMiddleware (Local s c )       = local ( responseLBS (toEnum s) [] c )+toMiddleware MethodOverride     = methodOverride+toMiddleware MethodOverridePost = methodOverridePost+toMiddleware (BasicAuth realm cred) = basicAuth (\u p -> return $ maybe False (==p) $ lookup u cred ) (fromString realm)+toMiddleware (AddHeaders headers)   = addHeaders headers++-- composeMiddleware :+composeMiddleware :: [Middleware] -> Middleware+composeMiddleware = foldl (flip (.)) id

@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Legacy types from Keter version 0.4. Retained to keep backwards+-- compatibility in config file format.+module Keter.Config.V04 where++import           Control.Applicative+import           Data.Aeson+import           Data.Bool+import           Data.Conduit.Network              (HostPreference)+import           Data.String                       (fromString)+import           Keter.Yaml.FilePath+import qualified System.FilePath                   as F+import           Keter.Common+import           Keter.Rewrite(ReverseProxyConfig)+import           Data.Text                  (Text)+import           System.FilePath            (FilePath)+import           Data.Set                   (Set)+import qualified Data.Set                   as Set+import qualified Network.Wai.Handler.Warp          as Warp+import qualified Network.Wai.Handler.WarpTLS       as WarpTLS+import qualified Network.TLS.SessionManager        as TLSSession+import           Prelude                           hiding (FilePath)++data AppConfig = AppConfig+    { configExec       :: F.FilePath+    , configArgs       :: [Text]+    , configHost       :: Text+    , configSsl        :: Bool+    , configExtraHosts :: Set Text+    , configRaw        :: Object+    }++instance ParseYamlFile AppConfig where+    parseYamlFile basedir = withObject "AppConfig" $ \o -> AppConfig+        <$> lookupBase basedir o "exec"+        <*> o .:? "args" .!= []+        <*> o .: "host"+        <*> o .:? "ssl" .!= False+        <*> o .:? "extra-hosts" .!= Set.empty+        <*> return o++data BundleConfig = BundleConfig+    { bconfigApp         :: Maybe AppConfig+    , bconfigStaticHosts :: Set StaticHost+    , bconfigRedirects   :: Set Redirect+    }++instance ParseYamlFile BundleConfig where+    parseYamlFile basedir = withObject "BundleConfig" $ \o -> BundleConfig+        <$> ((Just <$> parseYamlFile basedir (Object o)) <|> pure Nothing)+        <*> lookupBaseMaybe basedir o "static-hosts" .!= Set.empty+        <*> o .:? "redirects" .!= Set.empty++data StaticHost = StaticHost+    { shHost :: Text+    , shRoot :: FilePath+    }+    deriving (Eq, Ord)++instance ParseYamlFile StaticHost where+    parseYamlFile basedir = withObject "StaticHost" $ \o -> StaticHost+        <$> o .: "host"+        <*> lookupBase basedir o "root"++data Redirect = Redirect+    { redFrom :: Text+    , redTo   :: Text+    }+    deriving (Eq, Ord)++instance FromJSON Redirect where+    parseJSON (Object o) = Redirect+        <$> o .: "from"+        <*> o .: "to"+    parseJSON _ = fail "Wanted an object"++data KeterConfig = KeterConfig+    { kconfigDir                 :: F.FilePath+    , kconfigPortMan             :: PortSettings+    , kconfigHost                :: HostPreference+    , kconfigPort                :: Port+    , kconfigSsl                 :: Maybe TLSConfig+    , kconfigSetuid              :: Maybe Text+    , kconfigReverseProxy        :: Set ReverseProxyConfig+    , kconfigIpFromHeader        :: Bool+    , kconfigConnectionTimeBound :: Int+    -- ^ Maximum request time in milliseconds per connection.+    }++defaultKeterConfig :: KeterConfig+defaultKeterConfig = KeterConfig+        { kconfigDir = "."+        , kconfigPortMan = defaultPortSettings+        , kconfigHost = "*"+        , kconfigPort = 80+        , kconfigSsl = Nothing+        , kconfigSetuid = Nothing+        , kconfigReverseProxy = Set.empty+        , kconfigIpFromHeader = False+        , kconfigConnectionTimeBound = fiveMinutes+        }+++-- | Default connection time bound in milliseconds.+fiveMinutes :: Int+fiveMinutes = 5 * 60 * 1000++instance ParseYamlFile KeterConfig where+    parseYamlFile basedir = withObject "KeterConfig" $ \o -> KeterConfig+        <$> lookupBase basedir o "root"+        <*> o .:? "port-manager" .!= defaultPortSettings+        <*> (fmap fromString <$> o .:? "host") .!= kconfigHost defaultKeterConfig+        <*> o .:? "port" .!= kconfigPort defaultKeterConfig+        <*> (o .:? "ssl" >>= maybe (return Nothing) (fmap Just . parseYamlFile basedir))+        <*> o .:? "setuid"+        <*> o .:? "reverse-proxy" .!= Set.empty+        <*> o .:? "ip-from-header" .!= False+        <*> o .:? "connection-time-bound" .!= fiveMinutes++data TLSConfig = TLSConfig !Warp.Settings !FilePath !FilePath (Maybe TLSSession.Config)++instance ParseYamlFile TLSConfig where+    parseYamlFile basedir = withObject "TLSConfig" $ \o -> do+        cert <- lookupBase basedir o "certificate"+        key <- lookupBase basedir o "key"+        host <- (fmap fromString <$> o .:? "host") .!= "*"+        port <- o .:? "port" .!= 443+        session <- bool Nothing (Just TLSSession.defaultConfig) <$> o .:? "session" .!= False+        return $! TLSConfig+            (Warp.setHost host $ Warp.setPort port Warp.defaultSettings)+            cert+            key+            session++-- | Controls execution of the nginx thread. Follows the settings type pattern.+-- See: <http://www.yesodweb.com/book/settings-types>.+data PortSettings = PortSettings+    { portRange :: [Port]+      -- ^ Which ports to assign to apps. Defaults to unassigned ranges from IANA+    }++defaultPortSettings :: PortSettings+defaultPortSettings = PortSettings+        -- Top 10 Largest IANA unassigned port ranges with no unauthorized uses known+        { portRange = [43124..44320]+                      ++ [28120..29166]+                      ++ [45967..46997]+                      ++ [28241..29117]+                      ++ [40001..40840]+                      ++ [29170..29998]+                      ++ [38866..39680]+                      ++ [43442..44122]+                      ++ [41122..41793]+                      ++ [35358..36000]+        }++instance FromJSON PortSettings where+    parseJSON = withObject "PortSettings" $ \_ -> PortSettings+        <$> return (portRange defaultPortSettings)

@@ -0,0 +1,481 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+module Keter.Config.V10 where++import           Control.Applicative               ((<$>), (<*>), (<|>))+import           Data.Aeson                        (FromJSON (..), ToJSON (..), Object,+                                                    Value (Object, String, Bool),+                                                    withObject, (.!=), (.:),+                                                    (.:?), object, (.=))+import           Keter.Aeson.KeyHelper              as AK (lookup, singleton, empty, insert)+import qualified Data.CaseInsensitive              as CI+import           Data.Conduit.Network              (HostPreference)+import qualified Data.Map                          as Map+import           Data.Maybe                        (catMaybes, fromMaybe, isJust)+import qualified Data.Set                          as Set+import           Data.String                       (fromString)+import           Data.Vector                       (Vector)+import qualified Data.Vector                       as V+import           Data.Word                         (Word)+import           Keter.Yaml.FilePath+import qualified System.FilePath                   as F+import           Keter.Common+import           Keter.Config.Middleware+import qualified Keter.Config.V04                   as V04+import qualified Network.Wai.Handler.Warp          as Warp+import qualified Network.Wai.Handler.WarpTLS       as WarpTLS+import           System.Posix.Types                (EpochTime)+import           Keter.Rewrite(ReverseProxyConfig)+import           Data.Text                  (Text)+import           System.FilePath            (FilePath)+import           Data.Set                   (Set)+import           Data.Map                   (Map)++data BundleConfig = BundleConfig+    { bconfigStanzas :: !(Vector (Stanza ()))+    , bconfigPlugins :: !Object -- ^ settings used for plugins+    } deriving Show++instance ToCurrent BundleConfig where+    type Previous BundleConfig = V04.BundleConfig+    toCurrent (V04.BundleConfig webapp statics redirs) = BundleConfig+        { bconfigStanzas = V.concat+            [ maybe V.empty V.singleton $ fmap (flip Stanza False . StanzaWebApp . toCurrent) webapp+            , V.fromList $ map (flip Stanza False . StanzaStaticFiles . toCurrent) $ Set.toList statics+            , V.fromList $ map (flip Stanza False . StanzaRedirect . toCurrent) $ Set.toList redirs+            ]+        , bconfigPlugins =+            case webapp >>= AK.lookup "postgres" . V04.configRaw of+                Just (Bool True) -> AK.singleton "postgres" (Bool True)+                _ -> AK.empty+        }++instance ParseYamlFile BundleConfig where+    parseYamlFile basedir = withObject "BundleConfig" $ \o ->+        case AK.lookup "stanzas" o of+            Nothing -> (toCurrent :: V04.BundleConfig -> BundleConfig) <$> parseYamlFile basedir (Object o)+            Just _ -> current o+      where+        current o = BundleConfig+            <$> lookupBase basedir o "stanzas"+            <*> o .:? "plugins" .!= AK.empty++instance ToJSON BundleConfig where+    toJSON BundleConfig {..} = object+        [ "stanzas" .= bconfigStanzas+        , "plugins" .= bconfigPlugins+        ]++data ListeningPort = LPSecure !HostPreference !Port+                              !F.FilePath !(V.Vector F.FilePath) !F.FilePath+                              !Bool+                   | LPInsecure !HostPreference !Port++instance ParseYamlFile ListeningPort where+    parseYamlFile basedir = withObject "ListeningPort" $ \o -> do+        host <- (fmap fromString <$> o .:? "host") .!= "*"+        mcert <- lookupBaseMaybe basedir o "certificate"+        mkey <- lookupBaseMaybe basedir o "key"+        session <- o .:? "session" .!= False+        case (mcert, mkey) of+            (Nothing, Nothing) -> do+                port <- o .:? "port" .!= 80+                return $ LPInsecure host port+            (Just cert, Just key) -> do+                port <- o .:? "port" .!= 443+                chainCerts <- o .:? "chain-certificates"+                    >>= maybe (return V.empty) (parseYamlFile basedir)+                return $ LPSecure host port cert chainCerts key session+            _ -> fail "Must provide both certificate and key files"++data KeterConfig = KeterConfig+    { kconfigDir                 :: F.FilePath+    , kconfigPortPool            :: V04.PortSettings+    , kconfigListeners           :: !(NonEmptyVector ListeningPort)+    , kconfigSetuid              :: Maybe Text+    , kconfigBuiltinStanzas      :: !(V.Vector (Stanza ()))+    , kconfigIpFromHeader        :: Bool+    , kconfigExternalHttpPort    :: !Int+    -- ^ External HTTP port when generating APPROOTs.+    , kconfigExternalHttpsPort   :: !Int+    -- ^ External HTTPS port when generating APPROOTs.+    , kconfigEnvironment         :: !(Map Text Text)+    -- ^ Environment variables to be passed to all apps.+    , kconfigConnectionTimeBound :: !Int+    -- ^ Maximum request time in milliseconds per connection.+    , kconfigCliPort             :: !(Maybe Port)+    -- ^ Port for the cli to listen on++    , kconfigUnknownHostResponse  :: !(Maybe F.FilePath)+    , kconfigMissingHostResponse  :: !(Maybe F.FilePath)+    , kconfigProxyException       :: !(Maybe F.FilePath)+    }++instance ToCurrent KeterConfig where+    type Previous KeterConfig = V04.KeterConfig+    toCurrent (V04.KeterConfig dir portman host port ssl setuid rproxy ipFromHeader connectionTimeBound) = KeterConfig+        { kconfigDir = dir+        , kconfigPortPool = portman+        , kconfigListeners = NonEmptyVector (LPInsecure host port) (getSSL ssl)+        , kconfigSetuid = setuid+        , kconfigBuiltinStanzas = V.fromList $ map (flip Stanza False . (\rp -> StanzaReverseProxy rp [] Nothing)) $ Set.toList rproxy+        , kconfigIpFromHeader = ipFromHeader+        , kconfigExternalHttpPort = 80+        , kconfigExternalHttpsPort = 443+        , kconfigEnvironment = Map.empty+        , kconfigConnectionTimeBound = connectionTimeBound+        , kconfigCliPort             = Nothing+        , kconfigUnknownHostResponse  = Nothing+        , kconfigMissingHostResponse = Nothing+        , kconfigProxyException      = Nothing+        }+      where+        getSSL Nothing = V.empty+        getSSL (Just (V04.TLSConfig s cert key session)) = V.singleton $ LPSecure+            (Warp.getHost s)+            (Warp.getPort s)+            cert+            V.empty+            key+            (isJust session)++defaultKeterConfig :: KeterConfig+defaultKeterConfig = KeterConfig+        { kconfigDir = "."+        , kconfigPortPool = V04.defaultPortSettings+        , kconfigListeners = NonEmptyVector (LPInsecure "*" 80) V.empty+        , kconfigSetuid = Nothing+        , kconfigBuiltinStanzas = V.empty+        , kconfigIpFromHeader = False+        , kconfigExternalHttpPort = 80+        , kconfigExternalHttpsPort = 443+        , kconfigEnvironment = Map.empty+        , kconfigConnectionTimeBound = V04.fiveMinutes+        , kconfigCliPort             = Nothing+        , kconfigUnknownHostResponse  = Nothing+        , kconfigMissingHostResponse = Nothing+        , kconfigProxyException      = Nothing+        }++instance ParseYamlFile KeterConfig where+    parseYamlFile basedir = withObject "KeterConfig" $ \o ->+        case AK.lookup "listeners" o of+            Just _ -> current o+            Nothing -> old o <|> current o+      where+        old o = (toCurrent :: V04.KeterConfig -> KeterConfig) <$> parseYamlFile basedir (Object o)+        current o = KeterConfig+            <$> lookupBase basedir o "root"+            <*> o .:? "port-manager" .!= V04.defaultPortSettings+            <*> fmap (fromMaybe (kconfigListeners defaultKeterConfig)) (lookupBaseMaybe basedir o "listeners")+            <*> o .:? "setuid"+            <*> return V.empty+            <*> o .:? "ip-from-header" .!= False+            <*> o .:? "external-http-port" .!= 80+            <*> o .:? "external-https-port" .!= 443+            <*> o .:? "env" .!= Map.empty+            <*> o .:? "connection-time-bound" .!= V04.fiveMinutes+            <*> o .:? "cli-port"+            <*> o .:? "missing-host-response-file"+            <*> o .:? "unknown-host-response-file"+            <*> o .:? "proxy-exception-response-file"++-- | Whether we should force redirect to HTTPS routes.+type RequiresSecure = Bool++data Stanza port = Stanza (StanzaRaw port) RequiresSecure+  deriving Show++data StanzaRaw port+    = StanzaStaticFiles !StaticFilesConfig+    | StanzaRedirect !RedirectConfig+    | StanzaWebApp !(WebAppConfig port)+    | StanzaReverseProxy !ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)+    | StanzaBackground !BackgroundConfig+            -- FIXME console app+    deriving Show++-- | An action to be performed for a requested hostname.+--+-- This datatype is very similar to Stanza, but is necessarily separate since:+--+-- 1. Webapps will be assigned ports.+--+-- 2. Not all stanzas have an associated proxy action.+data ProxyActionRaw+    = PAPort Port !(Maybe Int)+    | PAStatic StaticFilesConfig+    | PARedirect RedirectConfig+    | PAReverseProxy ReverseProxyConfig ![ MiddlewareConfig ] !(Maybe Int)+    deriving Show++type ProxyAction = (ProxyActionRaw, RequiresSecure)++instance ParseYamlFile (Stanza ()) where+    parseYamlFile basedir = withObject "Stanza" $ \o -> do+        typ <- o .: "type"+        needsHttps <- o .:? "requires-secure" .!= False+        raw <- case typ of+            "static-files"  -> fmap StanzaStaticFiles $ parseYamlFile basedir $ Object o+            "redirect"      -> fmap StanzaRedirect $ parseYamlFile basedir $ Object o+            "webapp"        -> fmap StanzaWebApp $ parseYamlFile basedir $ Object o+            "reverse-proxy" -> StanzaReverseProxy <$> parseJSON (Object o)+                                                  <*> o .:? "middleware" .!= []+                                                  <*> o .:? "connection-time-bound"+            "background"    -> fmap StanzaBackground $ parseYamlFile basedir $ Object o+            _ -> fail $ "Unknown stanza type: " ++ typ+        return $ Stanza raw needsHttps++instance ToJSON (Stanza ()) where+    toJSON (Stanza raw rs) = addRequiresSecure rs raw++addRequiresSecure :: ToJSON a => Bool -> a -> Value+addRequiresSecure rs x =+    case toJSON x of+        Object o -> Object $ AK.insert "requires-secure" (toJSON rs) o+        v -> v++instance ToJSON (StanzaRaw ()) where+    toJSON (StanzaStaticFiles x) = addStanzaType "static-files" x+    toJSON (StanzaRedirect x) = addStanzaType "redirect" x+    toJSON (StanzaWebApp x) = addStanzaType "webapp" x+    toJSON (StanzaReverseProxy x _ _) = addStanzaType "reverse-proxy" x+    toJSON (StanzaBackground x) = addStanzaType "background" x++addStanzaType :: ToJSON a => Value -> a -> Value+addStanzaType t x =+    case toJSON x of+        Object o -> Object $ AK.insert "type" t o+        v -> v++data StaticFilesConfig = StaticFilesConfig+    { sfconfigRoot       :: !F.FilePath+    , sfconfigHosts      :: !(Set Host)+    , sfconfigListings   :: !Bool+    -- FIXME basic auth+    , sfconfigMiddleware :: ![ MiddlewareConfig ]+    , sfconfigTimeout    :: !(Maybe Int)+    , sfconfigSsl        :: !SSLConfig+    }+    deriving Show++instance ToCurrent StaticFilesConfig where+    type Previous StaticFilesConfig = V04.StaticHost+    toCurrent (V04.StaticHost host root) = StaticFilesConfig+        { sfconfigRoot       = root+        , sfconfigHosts      = Set.singleton $ CI.mk host+        , sfconfigListings   = True+        , sfconfigMiddleware = []+        , sfconfigTimeout    = Nothing+        , sfconfigSsl        = SSLFalse+        }++instance ParseYamlFile StaticFilesConfig where+    parseYamlFile basedir = withObject "StaticFilesConfig" $ \o -> StaticFilesConfig+        <$> lookupBase basedir o "root"+        <*> (Set.map CI.mk <$> (o .: "hosts" <|> (Set.singleton <$> (o .: "host"))))+        <*> o .:? "directory-listing" .!= False+        <*> o .:? "middleware" .!= []+        <*> o .:? "connection-time-bound"+        <*> o .:? "ssl" .!= SSLFalse++instance ToJSON StaticFilesConfig where+    toJSON StaticFilesConfig {..} = object+        [ "root" .= sfconfigRoot+        , "hosts" .= Set.map CI.original sfconfigHosts+        , "directory-listing" .= sfconfigListings+        , "middleware" .= sfconfigMiddleware+        , "connection-time-bound" .= sfconfigTimeout+        , "ssl" .= sfconfigSsl+        ]++data RedirectConfig = RedirectConfig+    { redirconfigHosts   :: !(Set Host)+    , redirconfigStatus  :: !Int+    , redirconfigActions :: !(Vector RedirectAction)+    , redirconfigSsl     :: !SSLConfig+    }+    deriving Show++instance ToCurrent RedirectConfig where+    type Previous RedirectConfig = V04.Redirect+    toCurrent (V04.Redirect from to) = RedirectConfig+        { redirconfigHosts = Set.singleton $ CI.mk from+        , redirconfigStatus = 301+        , redirconfigActions = V.singleton $ RedirectAction SPAny+                             $ RDPrefix False (CI.mk to) Nothing+        , redirconfigSsl = SSLFalse+        }++instance ParseYamlFile RedirectConfig where+    parseYamlFile _ = withObject "RedirectConfig" $ \o -> RedirectConfig+        <$> (Set.map CI.mk <$> ((o .: "hosts" <|> (Set.singleton <$> (o .: "host")))))+        <*> o .:? "status" .!= 303+        <*> o .: "actions"+        <*> o .:? "ssl" .!= SSLFalse++instance ToJSON RedirectConfig where+    toJSON RedirectConfig {..} = object+        [ "hosts" .= Set.map CI.original redirconfigHosts+        , "status" .= redirconfigStatus+        , "actions" .= redirconfigActions+        , "ssl" .= redirconfigSsl+        ]++data RedirectAction = RedirectAction !SourcePath !RedirectDest+    deriving Show++instance FromJSON RedirectAction where+    parseJSON = withObject "RedirectAction" $ \o -> RedirectAction+        <$> (maybe SPAny SPSpecific <$> (o .:? "path"))+        <*> parseJSON (Object o)++instance ToJSON RedirectAction where+    toJSON (RedirectAction path dest) =+        case toJSON dest of+            Object o ->+                case path of+                    SPAny -> Object o+                    SPSpecific x -> Object $ AK.insert "path" (String x) o+            v -> v++data SourcePath = SPAny+                | SPSpecific !Text+    deriving Show++data RedirectDest = RDUrl !Text+                  | RDPrefix !IsSecure !Host !(Maybe Port)+    deriving Show++instance FromJSON RedirectDest where+    parseJSON = withObject "RedirectDest" $ \o ->+        url o <|> prefix o+      where+        url o = RDUrl <$> o .: "url"+        prefix o = RDPrefix+            <$> o .:? "secure" .!= False+            <*> (CI.mk <$> o .: "host")+            <*> o .:? "port"++instance ToJSON RedirectDest where+    toJSON (RDUrl url) = object ["url" .= url]+    toJSON (RDPrefix secure host mport) = object $ catMaybes+        [ Just $ "secure" .= secure+        , Just $ "host" .= CI.original host+        , case mport of+            Nothing -> Nothing+            Just port -> Just $ "port" .= port+        ]++type IsSecure = Bool++data WebAppConfig port = WebAppConfig+    { waconfigExec        :: !F.FilePath+    , waconfigArgs        :: !(Vector Text)+    , waconfigEnvironment :: !(Map Text Text)+    , waconfigApprootHost :: !Host -- ^ primary host, used for approot+    , waconfigHosts       :: !(Set Host) -- ^ all hosts, not including the approot host+    , waconfigSsl         :: !SSLConfig+    , waconfigPort        :: !port+    , waconfigForwardEnv  :: !(Set Text)+     -- | how long are connections supposed to last+    , waconfigTimeout     :: !(Maybe Int)+     -- | how long in microseconds the app gets before we expect it to bind to+     --   a port (default 90 seconds)+    , waconfigEnsureAliveTimeout :: !(Maybe Int)+    }+    deriving Show++instance ToCurrent (WebAppConfig ()) where+    type Previous (WebAppConfig ()) = V04.AppConfig+    toCurrent (V04.AppConfig exec args host ssl hosts _raw) = WebAppConfig+        { waconfigExec = exec+        , waconfigArgs = V.fromList args+        , waconfigEnvironment = Map.empty+        , waconfigApprootHost = CI.mk host+        , waconfigHosts = Set.map CI.mk hosts+        , waconfigSsl = if ssl then SSLTrue else SSLFalse+        , waconfigPort = ()+        , waconfigForwardEnv = Set.empty+        , waconfigTimeout = Nothing+        , waconfigEnsureAliveTimeout = Nothing+        }++instance ParseYamlFile (WebAppConfig ()) where+    parseYamlFile basedir = withObject "WebAppConfig" $ \o -> do+        (ahost, hosts) <-+            (do+                h <- o .: "host"+                return (CI.mk h, Set.empty)) <|>+            (do+                hs <- o .: "hosts"+                case hs of+                    [] -> fail "Must provide at least one host"+                    h:hs' -> return (CI.mk h, Set.fromList $ map CI.mk hs'))+        WebAppConfig+            <$> lookupBase basedir o "exec"+            <*> o .:? "args" .!= V.empty+            <*> o .:? "env" .!= Map.empty+            <*> return ahost+            <*> return hosts+            <*> o .:? "ssl" .!= SSLFalse+            <*> return ()+            <*> o .:? "forward-env" .!= Set.empty+            <*> o .:? "connection-time-bound"+            <*> o .:? "ensure-alive-time-bound"++instance ToJSON (WebAppConfig ()) where+    toJSON WebAppConfig {..} = object+        [ "exec" .= waconfigExec+        , "args" .= waconfigArgs+        , "env" .= waconfigEnvironment+        , "hosts" .= map CI.original (waconfigApprootHost : Set.toList waconfigHosts)+        , "ssl" .= waconfigSsl+        , "forward-env" .= waconfigForwardEnv+        , "connection-time-bound" .= waconfigTimeout+        ]++data AppInput = AIBundle !FilePath !EpochTime+              | AIData !BundleConfig+              deriving Show++data BackgroundConfig = BackgroundConfig+    { bgconfigExec                :: !F.FilePath+    , bgconfigArgs                :: !(Vector Text)+    , bgconfigEnvironment         :: !(Map Text Text)+    , bgconfigRestartCount        :: !RestartCount+    , bgconfigRestartDelaySeconds :: !Word+    , bgconfigForwardEnv          :: !(Set Text)+    }+    deriving Show++data RestartCount = UnlimitedRestarts | LimitedRestarts !Word+    deriving Show++instance FromJSON RestartCount where+    parseJSON (String "unlimited") = return UnlimitedRestarts+    parseJSON v = LimitedRestarts <$> parseJSON v++instance ParseYamlFile BackgroundConfig where+    parseYamlFile basedir = withObject "BackgroundConfig" $ \o -> BackgroundConfig+        <$> lookupBase basedir o "exec"+        <*> o .:? "args" .!= V.empty+        <*> o .:? "env" .!= Map.empty+        <*> o .:? "restart-count" .!= UnlimitedRestarts+        <*> o .:? "restart-delay-seconds" .!= 5+        <*> o .:? "forward-env" .!= Set.empty++instance ToJSON BackgroundConfig where+    toJSON BackgroundConfig {..} = object $ catMaybes+        [ Just $ "exec" .= bgconfigExec+        , Just $ "args" .= bgconfigArgs+        , Just $ "env" .= bgconfigEnvironment+        , case bgconfigRestartCount of+            UnlimitedRestarts -> Nothing+            LimitedRestarts count -> Just $ "restart-count" .= count+        , Just $ "restart-delay-seconds" .= bgconfigRestartDelaySeconds+        , Just $ "forward-env" .= bgconfigForwardEnv+        ]