keter 0.4.0 → 1.0.1

raw patch · 29 files changed

+2946/−1865 lines, 29 filesdep +aesondep +asyncdep +stmdep ~basedep ~system-filepathdep ~unix-process-conduitnew-component:exe:helloPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, async, stm, unordered-containers, vector, wai-extra

Dependency ranges changed: base, system-filepath, unix-process-conduit, wai, yaml

API changes (from Hackage documentation)

Files

• Codec/Archive/TempTarball.hs +117/−0
• Data/Yaml/FilePath.hs +67/−0
• Keter/App.hs +515/−259
• Keter/AppManager.hs +249/−0
• Keter/HostManager.hs +180/−0
• Keter/LabelMap.hs +299/−0
• Keter/LogFile.hs +0/−79
• Keter/Logger.hs +0/−116
• Keter/Main.hs +161/−208
• Keter/Plugin/Postgres.hs +160/−0
• Keter/PortManager.hs +0/−166
• Keter/PortPool.hs +70/−0
• Keter/Postgres.hs +0/−151
• Keter/Prelude.hs +0/−314
• Keter/Process.hs +0/−92
• Keter/ProcessTracker.hs +0/−36
• Keter/Proxy.hs +115/−54
• Keter/ReverseProxy.hs +0/−189
• Keter/SSL.hs +0/−44
• Keter/TempFolder.hs +0/−41
• Keter/Types.hs +23/−0
• Keter/Types/Common.hs +167/−0
• Keter/Types/V04.hs +150/−0
• Keter/Types/V10.hs +375/−0
• Network/HTTP/ReverseProxy/Rewrite.hs +211/−0
• cbits/process-tracker.c +0/−100
• incoming/foo/hello.hs +37/−0
• keter.cabal +43/−15
• main/keter.hs +7/−1

@@ -0,0 +1,117 @@+{-# 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)+import           Data.Word                 (Word)+import qualified Filesystem                as F+import           Filesystem.Path.CurrentOS ((</>))+import qualified Filesystem.Path.CurrentOS as F+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    :: F.FilePath+    , tfCounter :: I.IORef Word+    }++setup :: F.FilePath -> IO TempFolder+setup fp = do+    e <- F.isDirectory fp+    when e $ F.removeTree fp+    F.createTree fp+    c <- I.newIORef minBound+    return $ TempFolder fp c++getFolder :: Maybe (UserID, GroupID)+          -> TempFolder+          -> Text -- ^ prefix for folder name+          -> IO F.FilePath+getFolder muid TempFolder {..} appname = do+    !i <- I.atomicModifyIORef tfCounter $ \i -> (succ i, i)+    let fp = tfRoot </> F.fromText (appname <> "-" <> pack (show i))+    F.createTree fp+    case muid of+        Nothing -> return ()+        Just (uid, gid) -> setOwnerAndGroup (F.encodeString fp) uid gid+    return fp++unpackTempTar :: Maybe (UserID, GroupID)+              -> TempFolder+              -> F.FilePath -- ^ bundle+              -> Text -- ^ prefix for folder name+              -> (F.FilePath -> IO a)+              -> IO a+unpackTempTar muid tf bundle appname withDir = do+    lbs <- L.readFile $ F.encodeString bundle+    bracketOnError (getFolder muid tf appname) F.removeTree $ \dir -> do+        unpackTar muid dir $ Tar.read $ decompress lbs+        withDir dir++unpackTar :: Maybe (UserID, GroupID)+          -> F.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 </> F.decodeString (Tar.entryPath e)+        case Tar.entryContent e of+            Tar.NormalFile lbs _ -> do+                case muid of+                    Nothing -> F.createTree $ F.directory fp+                    Just (uid, gid) -> createTreeUID uid gid $ F.directory fp+                let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do+                        _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len)+                        return ()+                bracket+                    (do+                        fd <- createFile (F.encodeString 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 -> F.FilePath -> IO ()+createTreeUID uid gid =+    go+  where+    go fp = do+        exists <- F.isDirectory fp+        unless exists $ do+            go $ F.parent fp+            F.createDirectory False fp+            setOwnerAndGroup (F.encodeString fp) uid gid

@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- | 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 Filesystem.Path.CurrentOS (FilePath, encodeString, directory, fromText, (</>))+import Data.Yaml (decodeFileEither, ParseException (AesonException), parseJSON)+import Prelude (($!), ($), Either (..), return, IO, (.), (>>=), Maybe (..), maybe, mapM, Ord, fail)+import Data.Aeson.Types ((.:), (.:?), Object, Parser, Value, parseEither)+import Data.Text (Text)+import qualified Data.Set as Set+import qualified Data.Vector as V++-- | 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 $ encodeString 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 $ directory 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 t = (o .: t) >>= parseYamlFile basedir++-- | 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 t = (o .:? t) >>= maybe (return Nothing) ((Just <$>) . parseYamlFile basedir)++-- | 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 </>) . fromText) <$> 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,239 +1,393 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell     #-} module Keter.App     ( App+    , AppStartConfig (..)     , start     , reload+    , getTimestamp     , Keter.App.terminate     ) where -import Prelude (IO, Eq, Ord, fst, snd)-import Keter.Prelude-import Keter.TempFolder-import Keter.Postgres-import Keter.Process-import Keter.ProcessTracker (ProcessTracker)-import Keter.Logger (Logger, detach)-import Keter.PortManager hiding (start)-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           Codec.Archive.TempTarball+import           Control.Applicative       ((<$>), (<*>))+import           Control.Arrow             ((***))+import           Control.Concurrent        (forkIO, threadDelay)+import           Control.Concurrent.STM+import           Control.Exception         (bracketOnError, throwIO)+import           Control.Exception         (IOException, try)+import           Control.Monad             (void, when)+import qualified Data.Conduit.LogFile      as LogFile+import           Data.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,+                                            RotatingLog, monitorProcess,+                                            terminateMonitoredProcess)+import           Data.IORef+import qualified Data.Map                  as Map+import           Data.Maybe                (fromMaybe)+import           Data.Monoid               ((<>))+import qualified Data.Set                  as Set+import           Data.Text                 (pack)+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           Filesystem                (canonicalizePath, isFile,+                                            removeTree) import qualified Filesystem.Path.CurrentOS as F-import qualified Filesystem as F-import Data.Yaml-import Control.Applicative ((<$>), (<*>), (<|>), pure)+import           Keter.HostManager         hiding (start)+import           Keter.PortPool            (PortPool, getPort, releasePort)+import           Keter.Types import qualified Network-import Data.Maybe (fromMaybe, mapMaybe)-import Control.Exception (onException, throwIO, bracket)-import System.IO (hClose)-import qualified Data.ByteString.Lazy as L-import Data.Conduit (($$), yield)-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Conduit.List as CL-import System.Posix.IO (fdWriteBuf, closeFd, FdOption (CloseOnExec), setFdOption, createFile)-import Foreign.Ptr (castPtr)-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import Data.Text.Encoding (encodeUtf8)-import System.Posix.Types (UserID, GroupID)-import System.Posix.Files (setOwnerAndGroup, setFdOwnerAndGroup)-import Control.Monad (unless)+import           Prelude                   hiding (FilePath)+import           System.IO                 (hClose)+import           System.Posix.Files        (fileAccess)+import           System.Posix.Types        (EpochTime)+import           System.Posix.Types        (GroupID, UserID)+import           System.Timeout            (timeout) -data AppConfig = AppConfig-    { configExec :: F.FilePath-    , configArgs :: [Text]-    , configHost :: Text-    , configPostgres :: Bool-    , configSsl :: Bool-    , configExtraHosts :: Set String+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 FromJSON AppConfig where-    parseJSON (Object o) = AppConfig-        <$> (F.fromText <$> o .: "exec")-        <*> o .:? "args" .!= []-        <*> o .: "host"-        <*> o .:? "postgres" .!= False-        <*> o .:? "ssl" .!= False-        <*> o .:? "extra-hosts" .!= Set.empty-    parseJSON _ = fail "Wanted an object"+data RunningWebApp = RunningWebApp+    { rwaProcess :: !MonitoredProcess+    , rwaPort    :: !Port+    } -data Config = Config-    { configApp :: Maybe AppConfig-    , configStaticHosts :: Set StaticHost-    , configRedirects :: Set Redirect+newtype RunningBackgroundApp = RunningBackgroundApp+    { rbaProcess             :: MonitoredProcess     } -instance FromJSON Config where-    parseJSON (Object o) = Config-        <$> ((Just <$> parseJSON (Object o)) <|> pure Nothing)-        <*> o .:? "static-hosts" .!= Set.empty-        <*> o .:? "redirects" .!= Set.empty-    parseJSON _ = fail "Wanted an object"+unpackBundle :: AppStartConfig+             -> FilePath+             -> AppId+             -> IO (FilePath, BundleConfig)+unpackBundle AppStartConfig {..} bundle aid = do+    ascLog $ UnpackingBundle bundle+    unpackTempTar (fmap snd ascSetuid) ascTempFolder bundle folderName $ \dir -> do+        let configFP = dir F.</> "config" F.</> "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 StaticHost = StaticHost-    { shHost :: String-    , shRoot :: FilePath+data AppStartConfig = AppStartConfig+    { ascTempFolder     :: !TempFolder+    , ascSetuid         :: !(Maybe (Text, (UserID, GroupID)))+    , ascProcessTracker :: !ProcessTracker+    , ascHostManager    :: !HostManager+    , ascPortPool       :: !PortPool+    , ascPlugins        :: !Plugins+    , ascLog            :: !(LogMessage -> IO ())+    , ascKeterConfig    :: !KeterConfig     }-    deriving (Eq, Ord) -instance FromJSON StaticHost where-    parseJSON (Object o) = StaticHost-        <$> o .: "host"-        <*> (F.fromText <$> o .: "root")-    parseJSON _ = fail "Wanted an object"+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, _) -> removeTree newdir)+    $ \(newdir, bconfig) -> f (Just newdir) bconfig (Just modtime) -data Redirect = Redirect-    { redFrom :: Text-    , redTo :: Text-    }-    deriving (Eq, Ord)+withReservations :: AppStartConfig+                 -> AppId+                 -> BundleConfig+                 -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> 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) -instance FromJSON Redirect where-    parseJSON (Object o) = Redirect-        <$> o .: "from"-        <*> o .: "to"-    parseJSON _ = fail "Wanted an object"+withActions :: AppStartConfig+            -> BundleConfig+            -> ([WebAppConfig Port] -> [BackgroundConfig] -> Map Host ProxyAction -> IO a)+            -> IO a+withActions asc bconfig f =+    loop (V.toList $ bconfigStanzas bconfig) [] [] Map.empty+  where+    loop [] wacs backs actions = f wacs backs actions+    loop (StanzaWebApp wac:stanzas) wacs backs actions = bracketOnError+        (getPort (ascLog asc) (ascPortPool asc) >>= either throwIO return)+        (releasePort (ascPortPool asc))+        (\port -> loop+            stanzas+            (wac { waconfigPort = port } : wacs)+            backs+            (Map.unions $ actions : map (\host -> Map.singleton host $ PAPort port) hosts))+      where+        hosts = Set.toList $ Set.insert (waconfigApprootHost wac) (waconfigHosts wac)+    loop (StanzaStaticFiles sfc:stanzas) wacs backs actions0 =+        loop stanzas wacs backs actions+      where+        actions = Map.unions+                $ actions0+                : map (\host -> Map.singleton host $ PAStatic sfc)+                  (Set.toList (sfconfigHosts sfc))+    loop (StanzaRedirect red:stanzas) wacs backs actions0 =+        loop stanzas wacs backs actions+      where+        actions = Map.unions+                $ actions0+                : map (\host -> Map.singleton host $ PARedirect red)+                  (Set.toList (redirconfigHosts red))+    loop (StanzaReverseProxy rev:stanzas) wacs backs actions0 =+        loop stanzas wacs backs actions+      where+        actions = Map.insert (reversingHost rev) (PAReverseProxy rev) actions0+    loop (StanzaBackground back:stanzas) wacs backs actions =+        loop stanzas wacs (back:backs) actions -data Command = Reload | Terminate-newtype App = App (Command -> KIO ())+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 (F.encodeString dir) LogFile.defaultMaxTotal)+            LogFile.close+            (f var)+        Just rlog ->  f var rlog+  where+    dir = kconfigDir ascKeterConfig F.</> "log" F.</> name+    name =+        case aid of+            AIBuiltin -> "__builtin__"+            AINamed x -> F.fromText $ "app-" <> x -unpackBundle :: TempFolder-             -> Maybe (UserID, GroupID)-             -> F.FilePath-             -> Appname-             -> KIO (Either SomeException (FilePath, Config))-unpackBundle tf muid bundle appname = do-    elbs <- readFileLBS bundle-    case elbs of-        Left e -> return $ Left e-        Right lbs -> do-            edir <- getFolder muid tf appname-            case edir of-                Left e -> return $ Left e-                Right dir -> do-                    log $ UnpackingBundle bundle dir-                    let rest = do-                            unpackTar muid dir $ Tar.read $ decompress lbs-                            let configFP = dir F.</> "config" F.</> "keter.yaml"-                            mconfig <- decodeFile $ F.encodeString configFP-                            config <--                                case mconfig of-                                    Just config -> return config-                                    Nothing -> throwIO InvalidConfigFile-                            return (dir, config-                                { configStaticHosts = Set.fromList-                                                    $ mapMaybe (fixStaticHost dir)-                                                    $ Set.toList-                                                    $ configStaticHosts config-                                })-                    liftIO $ rest `onException` removeTree dir+withSanityChecks :: AppStartConfig -> BundleConfig -> IO a -> IO a+withSanityChecks AppStartConfig {..} BundleConfig {..} f = do+    V.mapM_ go bconfigStanzas+    ascLog SanityChecksPassed+    f+  where+    go (StanzaWebApp WebAppConfig {..}) = isExec waconfigExec+    go (StanzaBackground BackgroundConfig {..}) = isExec bgconfigExec+    go _ = return () --- | Ensures that the given path does not escape the containing folder and sets--- the pathname based on config file location.-fixStaticHost :: FilePath -> StaticHost -> Maybe StaticHost-fixStaticHost dir sh =-    case (F.stripPrefix (F.collapse dir F.</> "") fp, F.relative fp0) of-        (Just _, True) -> Just sh { shRoot = fp }-        _ -> Nothing+    isExec fp = do+        exists <- isFile fp+        if exists+            then do+                canExec <- fileAccess (F.encodeString 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-    fp0 = shRoot sh-    fp = F.collapse $ dir F.</> "config" F.</> fp0+    loop front [] = inside $ front []+    loop front (c:cs) = with c $ \x -> loop (front . (x:)) cs --- | Create a directory tree, setting the uid and gid of all newly created--- folders.-createTreeUID :: UserID -> GroupID -> FilePath -> IO ()-createTreeUID uid gid =-    go+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-    go fp = do-        exists <- F.isDirectory fp-        unless exists $ do-            go $ F.parent fp-            F.createDirectory False fp-            setOwnerAndGroup (F.encodeString fp) uid gid+    alloc = launchWebApp asc aid bconfig mdir rlog -unpackTar :: Maybe (UserID, GroupID)-          -> FilePath -> Tar.Entries Tar.FormatError -> IO ()-unpackTar muid dir =-    loop . Tar.checkSecurity+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+    let env = ("PORT", pack $ show waconfigPort)+            : ("APPROOT", (if waconfigSsl then "https://" else "http://") <> waconfigApprootHost)+            : Map.toList waconfigEnvironment ++ otherEnv+    exec <- canonicalizePath waconfigExec+    bracketOnError+        (monitorProcess+            (ascLog . OtherMessage . decodeUtf8With lenientDecode)+            ascProcessTracker+            (encodeUtf8 . fst <$> ascSetuid)+            (encodeUtf8 $ either id id $ F.toText exec)+            (maybe "/tmp" (encodeUtf8 . either id id . F.toText) mdir)+            (map encodeUtf8 $ V.toList waconfigArgs)+            (map (encodeUtf8 *** encodeUtf8) env)+            rlog+            (const $ return True))+        terminateMonitoredProcess+        $ \mp -> f RunningWebApp+            { rwaProcess = mp+            , rwaPort = waconfigPort+            }   where-    loop Tar.Done = return ()-    loop (Tar.Fail e) = either throwIO throwIO e-    loop (Tar.Next e es) = go e >> loop es+    name =+        case aid of+            AIBuiltin -> "__builtin__"+            AINamed x -> x -    go e = do-        let fp = dir </> decodeString (Tar.entryPath e)-        case Tar.entryContent e of-            Tar.NormalFile lbs _ -> do-                case muid of-                    Nothing -> createTree $ F.directory fp-                    Just (uid, gid) -> createTreeUID uid gid $ F.directory fp-                let write fd bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do-                        _ <- fdWriteBuf fd (castPtr ptr) (fromIntegral len)-                        return ()-                bracket-                    (do-                        fd <- createFile (F.encodeString 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_ yield (L.toChunks lbs) $$ CL.mapM_ (write fd))-            _ -> return ()+killWebApp :: RunningWebApp -> IO ()+killWebApp RunningWebApp {..} = do+    terminateMonitoredProcess rwaProcess +ensureAlive :: RunningWebApp -> IO ()+ensureAlive RunningWebApp {..} = do+    didAnswer <- testApp rwaPort+    if didAnswer+        then return ()+        else error "ensureAlive failed"+  where+    testApp :: Port -> IO Bool+    testApp port = do+        res <- timeout (90 * 1000 * 1000) testApp'+        return $ fromMaybe False res+      where+        testApp' = do+            threadDelay $ 2 * 1000 * 1000+            eres <- try $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port+            case eres of+                Left (_ :: IOException) -> testApp'+                Right handle -> do+                    hClose handle+                    return True++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+    let env = Map.toList bgconfigEnvironment ++ otherEnv+    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 $ either id id $ F.toText exec)+            (maybe "/tmp" (encodeUtf8 . either id id . F.toText) mdir)+            (map encodeUtf8 $ V.toList bgconfigArgs)+            (map (encodeUtf8 *** encodeUtf8) env)+            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-      -> PortManager-      -> Postgres-      -> Logger+      -> HostManager+      -> Plugins+      -> RotatingLog       -> Appname-      -> F.FilePath -- ^ app bundle+      -> (Maybe BundleConfig)       -> KIO () -- ^ action to perform to remove this App from list of actives       -> KIO (App, KIO ())-start tf muid processTracker portman postgres logger appname bundle removeFromList = do+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-    runApp port dir config = do-        otherEnv <- do-            mdbi <--                if configPostgres config-                    then do-                        edbi <- getInfo postgres appname-                        case edbi of-                            Left e -> do-                                $logEx e-                                return Nothing-                            Right dbi -> return $ Just dbi-                    else return Nothing-            return $ case mdbi of-                Just dbi ->-                    [ ("PGHOST", "localhost")-                    , ("PGPORT", "5432")-                    , ("PGUSER", dbiUser dbi)-                    , ("PGPASS", dbiPass dbi)-                    , ("PGDATABASE", dbiName dbi)-                    ]-                Nothing -> []-        let env = ("PORT", show port)-                : ("APPROOT", (if configSsl config then "https://" else "http://") ++ configHost config)-                : otherEnv-        run-            processTracker-            (fst <$> muid)-            ("config" </> configExec config)-            dir-            (configArgs config)-            env-            logger      rest chan = forkKIO $ do         mres <- unpackBundle tf (snd <$> muid) bundle appname@@ -243,9 +397,9 @@                 removeFromList             Right (dir, config) -> do                 let common = do-                        mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ configStaticHosts config-                        mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ configRedirects config-                case configApp config of+                        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@@ -256,34 +410,38 @@                                 $logEx e                                 removeFromList                             Right port -> do-                                process <- runApp port dir appconfig-                                b <- testApp port-                                if b-                                    then do-                                        addEntry portman (configHost appconfig) $ PEPort port-                                        mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ configExtraHosts appconfig-                                        common-                                        loop chan dir config $ Just (process, port)-                                    else do+                                eprocess <- runApp port dir appconfig+                                case eprocess of+                                    Left e -> do+                                        $logEx e                                         removeFromList-                                        releasePort portman port-                                        Keter.Process.terminate process+                                    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 configApp configOld of+                case bconfigApp configOld of                     Nothing -> return ()                     Just appconfig -> do-                        removeEntry portman $ configHost appconfig-                        mapM_ (removeEntry portman) $ Set.toList $ configExtraHosts appconfig-                mapM_ (removeEntry portman) $ map shHost $ Set.toList $ configStaticHosts configOld-                mapM_ (removeEntry portman) $ map redFrom $ Set.toList $ configRedirects configOld+                        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-                detach logger             Reload -> do                 mres <- unpackBundle tf (snd <$> muid) bundle appname                 case mres of@@ -296,65 +454,163 @@                             Left e -> $logEx e                             Right port -> do                                 let common = do-                                        mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ configStaticHosts config-                                        mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ configRedirects config-                                case configApp config of+                                        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-                                        process <- runApp port dir appconfig-                                        b <- testApp port-                                        if b-                                            then do-                                                addEntry portman (configHost appconfig) $ PEPort port-                                                mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ configExtraHosts appconfig+                                        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 configApp configOld of-                                                    Just appconfigOld | configHost appconfig /= configHost appconfigOld ->-                                                        removeEntry portman $ configHost appconfigOld+                                                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)-                                            else do+                                            Nothing -> do                                                 releasePort portman port-                                                Keter.Process.terminate process+                                                case eprocess of+                                                    Left _ -> return ()+                                                    Right process -> void $ liftIO $ terminateMonitoredProcess process                                                 log $ ProcessDidNotStart bundle                                                 loop chan dirOld configOld mprocPortOld       where         terminateOld = forkKIO $ do-            threadDelay $ 20 * 1000 * 1000-            log $ TerminatingOldProcess appname-            case mprocPortOld of-                Nothing -> return ()-                Just (processOld, _) -> Keter.Process.terminate processOld-            threadDelay $ 60 * 1000 * 1000-            log $ RemovingOldFolder dirOld-            res <- liftIO $ removeTree dirOld+    -}++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) <- atomically $ do+            oldApps <- readTVar appRunningWebApps+            oldBacks <- readTVar appBackgroundApps+            oldDir <- readTVar appDir++            writeTVar appModTime mmodtime+            writeTVar appRunningWebApps runningWebapps+            writeTVar appBackgroundApps runningBacks+            writeTVar appHosts $ Map.keysSet actions+            writeTVar appDir newdir+            return (oldApps, oldBacks, oldDir)+        void $ forkIO $ terminateHelper appAsc appId oldApps oldBacks oldDir++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+    maybe (return ()) LogFile.close rlog+  where+    AppStartConfig {..} = appAsc++terminateHelper :: AppStartConfig+                -> AppId+                -> [RunningWebApp]+                -> [RunningBackgroundApp]+                -> Maybe FilePath+                -> IO ()+terminateHelper AppStartConfig {..} aid apps backs mdir = do+    threadDelay $ 20 * 1000 * 1000+    ascLog $ TerminatingOldProcess aid+    mapM_ killWebApp apps+    mapM_ killBackgroundApp backs+    threadDelay $ 60 * 1000 * 1000+    case mdir of+        Nothing -> return ()+        Just dir -> do+            ascLog $ RemovingOldFolder dir+            res <- try $ removeTree dir             case res of-                Left e -> $logEx e+                Left e -> $logEx ascLog e                 Right () -> return () -testApp :: Port -> KIO Bool-testApp port = do-    res <- timeout (90 * 1000 * 1000) testApp'-    return $ fromMaybe False res-  where-    testApp' = do-        threadDelay $ 2 * 1000 * 1000-        eres <- liftIO $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port-        case eres of-            Left _ -> testApp'-            Right handle -> do-                res <- liftIO $ hClose handle-                case res of-                    Left e -> $logEx e-                    Right () -> return ()-                return True+-- | Get the modification time of the bundle file this app was launched from,+-- if relevant.+getTimestamp :: App -> STM (Maybe EpochTime)+getTimestamp = readTVar . appModTime -reload :: App -> KIO ()-reload (App f) = f Reload+pluginsGetEnv :: Plugins -> Appname -> Object -> IO [(Text, Text)]+pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps -terminate :: App -> KIO ()-terminate (App f) = f Terminate+    {- 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,249 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE RecordWildCards   #-}+-- | Used for management of applications.+module Keter.AppManager+    ( -- * Types+      AppManager+    , Action (..)+      -- * Actions+    , perform+    , reloadAppList+    , addApp+    , terminateApp+      -- * Initialize+    , initialize+    ) 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 qualified Data.Map                  as Map+import           Data.Maybe                (mapMaybe)+import           Data.Maybe                (catMaybes)+import qualified Data.Set                  as Set+import qualified Filesystem.Path.CurrentOS as F+import           Keter.App                 (App, AppStartConfig)+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)++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++data Action = Reload AppInput | Terminate++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+        App.terminate app+        return Nothing+    processAction Nothing (Reload input) = do+        eres <- E.try $ App.start appStartConfig appid input+        case eres of+            Left e -> do+                let name =+                        case appid of+                            AIBuiltin -> "<builtin>"+                            AINamed x -> x+                log $ ErrorStartingBundle name e+                return Nothing+            Right app -> return $ Just app+    processAction (Just app) (Reload input) = do+        App.reload app input+        -- 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++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 (F.encodeString bundle)+    return (AINamed $ getAppname bundle, Reload $ AIBundle bundle time)++terminateApp :: AppManager -> Appname -> IO ()+terminateApp appMan appname = perform appMan (AINamed appname) Terminate

@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# 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           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
+
+type HMState = LabelMap HostValue
+
+data HostValue = HVActive   !AppId !ProxyAction
+               | 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 host
+
+    hvres = HVReserved aid
+    reserve host es =
+        assert (not $ LabelMap.labelAssigned hostBS es) $ LabelMap.insert hostBS hvres es
+      where
+        hostBS = encodeUtf8 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 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
+            -> 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 -> HMState
+activateHelper app =
+    Map.foldrWithKey activate
+  where
+    activate host action state =
+        assert isOwnedByMe $ LabelMap.insert hostBS (HVActive app action) state
+      where
+        hostBS = encodeUtf8 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 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
+              -> 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)
+lookupAction (HostManager mstate) host = do
+    state <- readIORef mstate
+    return $ case LabelMap.lookup host state of
+        Nothing -> Nothing
+        Just (HVActive _ action) -> Just action
+        Just (HVReserved _) -> Nothing

@@ -0,0 +1,299 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+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)++type LabelTree a = Map 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)++-- | Indicates whether a given label in the+data LabelEntry a = Assigned   !a !(LabelMap a)+                  | Unassigned    !(LabelMap a)++instance Show (LabelEntry a) where+    show (Assigned _ m) = "Assigned _ (" ++ show m ++ ")"+    show (Unassigned m) = "Unassigned (" ++ show m ++ ")"++hostToLabels :: ByteString -> [ByteString]+hostToLabels h =+  if BS.null h+  then []+  else +    if BS.last h == '.'+    then drop 1 $ labels+    else labels+  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 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)++insertTree ["*"] e (Wildcard w) = Wildcard (Assigned e (labelEntryMap w))+insertTree [l]   e (Wildcard w) = WildcardExcept w (Map.insert 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)++insertTree ("*":ls) e EmptyLabelMap = Wildcard (Unassigned (insertTree ls e EmptyLabelMap))+insertTree (l:ls)   e EmptyLabelMap = Static (Map.insert 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)++insertTree ("*":ls) e (Wildcard w) = Wildcard (lemap (insertTree ls e) w)+insertTree (l:ls)   e (Wildcard w) = WildcardExcept w (Map.insert 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)++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 (Map.delete l t)++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 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)++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)++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 l t >>= getPortEntry+lookupTree [_] (Wildcard w) = getPortEntry $ w+lookupTree [l] (WildcardExcept w t) =+    case Map.lookup l t >>= getPortEntry of+        Just e  -> Just e+        Nothing -> getPortEntry w++lookupTree (l:ls) (Static t) =+    case Map.lookup 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 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 l t >>= getPortEntry++memberTree ["*"] (Wildcard _) = True+memberTree [_]   (Wildcard _) = False++memberTree ["*"] (WildcardExcept w _) = isJust $ getPortEntry w+memberTree [l]   (WildcardExcept _ t) = isJust $ Map.lookup l t >>= getPortEntry++memberTree ("*":_) (Static _) = False+memberTree (l:ls)  (Static t) =+    case Map.lookup 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 l t of+        Just le -> memberTree ls $ labelEntryMap le+        Nothing -> False++memberTree _ EmptyLabelMap = False++empty :: LabelMap a+empty = EmptyLabelMap

@@ -1,79 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-module Keter.LogFile-    ( LogFile-    , start-    , addChunk-    , close-    ) where--import Keter.Prelude hiding (getCurrentTime)-import qualified Data.ByteString as S-import Data.Time (getCurrentTime)-import qualified System.IO as SIO-import qualified Filesystem as F-import qualified Data.Text as T--data Command = AddChunk S.ByteString-             | Close--newtype LogFile = LogFile (Command -> KIO ())--addChunk :: LogFile -> S.ByteString -> KIO ()-addChunk (LogFile f) bs = f $ AddChunk bs--close :: LogFile -> KIO ()-close (LogFile f) = f Close--start :: FilePath -- ^ folder to contain logs-      -> KIO (Either SomeException LogFile)-start dir = do-    res <- liftIO $ do-        createTree dir-        moveCurrent Nothing-    case res of-        Left e -> return $ Left e-        Right handle -> do-            chan <- newChan-            forkKIO $ loop chan handle 0-            return $ Right $ LogFile $ writeChan chan-  where-    current = dir </> "current.log"-    moveCurrent mhandle = do-        maybe (return ()) SIO.hClose mhandle-        x <- isFile current-        when x $ do-            now <- getCurrentTime-            rename current $ dir </> suffix now-        F.openFile current F.WriteMode-    suffix now = fromText (T.concatMap fix $ T.takeWhile (/= '.') $ show now) <.> "log"-    fix ' ' = "_"-    fix c | '0' <= c && c <= '9' = T.singleton c-    fix _ = T.empty-    loop chan handle total = do-        c <- readChan chan-        case c of-            AddChunk bs -> do-                let total' = total + S.length bs-                res <- liftIO $ S.hPut handle bs >> SIO.hFlush handle-                either $logEx return res-                if total' > maxTotal-                    then do-                        res2 <- liftIO $ moveCurrent $ Just handle-                        case res2 of-                            Left e -> do-                                $logEx e-                                deadLoop chan-                            Right handle' -> loop chan handle' 0-                    else loop chan handle total'-            Close ->-                liftIO (SIO.hClose handle) >>=-                    either $logEx return-    deadLoop chan = do-        c <- readChan chan-        case c of-            AddChunk _ -> deadLoop chan-            Close -> return ()--    maxTotal = 5 * 1024 * 1024 -- 5 MB

@@ -1,116 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-module Keter.Logger-    ( Logger-    , start-    , attach-    , detach-    , LogPipes (..)-    , LogPipe-    , mkLogPipe-    , dummy-    ) where--import Keter.Prelude-import qualified Prelude as P-import qualified Keter.LogFile as LogFile-import Control.Concurrent (killThread)-import qualified Data.ByteString as S-import Data.Conduit (Sink, await)-import qualified Control.Concurrent.MVar as M-import Control.Monad.Trans.Class (lift)--data LogPipes = LogPipes-    { stdOut :: LogPipe-    , stdErr :: LogPipe-    }--data LogPipe = LogPipe-    { readLogPipe :: KIO (Maybe S.ByteString)-    , closeLogPipe :: KIO ()-    }--mkLogPipe :: KIO (LogPipe, Sink S.ByteString P.IO ())-mkLogPipe = do-    toSink <- newEmptyMVar-    fromSink <- newEmptyMVar-    let pipe = LogPipe-            { readLogPipe = do-                putMVar toSink True-                takeMVar fromSink-            , closeLogPipe = do-                _ <- tryTakeMVar toSink-                putMVar toSink False-            }-        sink = do-            toCont <- lift $ M.takeMVar toSink-            if toCont-                then do-                    mbs <- await-                    lift $ M.putMVar fromSink mbs-                    maybe (return ()) (P.const sink) mbs-                else return ()-    return (pipe, sink)--newtype Logger = Logger (Command -> KIO ())--data Command = Attach LogPipes | Detach--start :: LogFile.LogFile -- ^ stdout-      -> LogFile.LogFile -- ^ stderr-      -> KIO Logger-start lfout lferr = do-    chan <- newChan-    forkKIO $ loop chan Nothing Nothing-    return $ Logger $ writeChan chan-  where-    killOld tid = do-        res <- liftIO $ killThread tid-        case res of-            Left e -> $logEx e-            Right () -> return ()--    loop chan moldout molderr = do-        c <- readChan chan-        maybe (return ()) killOld moldout-        maybe (return ()) killOld molderr-        case c of-            Detach -> do-                LogFile.close lfout-                LogFile.close lferr-            Attach (LogPipes out err) -> do-                LogFile.addChunk lfout "\n\nAttaching new process\n\n"-                LogFile.addChunk lferr "\n\nAttaching new process\n\n"-                let go logpipe lf = do-                        etid <- forkKIO' $ listener logpipe lf-                        case etid of-                            Left e -> do-                                $logEx e-                                closeLogPipe logpipe-                                return Nothing-                            Right tid -> return $ Just tid-                newout <- go out lfout-                newerr <- go err lferr-                loop chan newout newerr--listener :: LogPipe -> LogFile.LogFile -> KIO ()-listener out lf =-    loop-  where-    loop = do-        mbs <- readLogPipe out-        case mbs of-            Nothing -> return ()-            Just bs -> do-                LogFile.addChunk lf bs-                loop--attach :: Logger -> LogPipes -> KIO ()-attach (Logger f) h = f (Attach h)--detach :: Logger -> KIO ()-detach (Logger f) = f Detach--dummy :: Logger-dummy = Logger $ P.const $ return ()

@@ -1,97 +1,106 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns      #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-} module Keter.Main     ( keter     ) where -import Keter.Prelude hiding (getCurrentTime)-import qualified Keter.TempFolder as TempFolder-import qualified Keter.App as App-import qualified Keter.ProcessTracker as ProcessTracker-import qualified Keter.Postgres as Postgres-import qualified Keter.LogFile as LogFile-import qualified Keter.Logger as Logger-import qualified Keter.PortManager as PortMan-import qualified Keter.Proxy as Proxy-import qualified Keter.ReverseProxy as ReverseProxy-import System.Posix.Files (modificationTime, getFileStatus)-import System.Posix.Signals (sigHUP, installHandler, Handler (Catch))+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 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 Data.Conduit.Network (HostPreference)-import qualified Control.Concurrent.MVar as M-import Control.Concurrent (forkIO)-import qualified Data.Map as Map-import qualified System.FSNotify as FSN-import Control.Monad (forever, mzero, forM)-import qualified Filesystem.Path.CurrentOS as F-import qualified Filesystem as F-import Control.Exception (throwIO, try)-import qualified Prelude as P-import Data.Text.Encoding (encodeUtf8)-import Data.Time (getCurrentTime)-import qualified Data.Text as T-import Data.Maybe (fromMaybe, catMaybes)-import Data.Yaml (decodeFile, FromJSON (parseJSON), Value (Object), (.:), (.:?), (.!=))-import Control.Applicative ((<$>), (<*>))-import Data.String (fromString)-import System.Posix.User (userID, userGroupID, getUserEntryForName, getUserEntryForID, userName)+import           Control.Applicative       ((<$>))+import           Control.Exception         (throwIO, try)+import           Control.Monad             (forM)+import           Data.Conduit.Process.Unix (initProcessTracker)+import qualified Data.Map                  as Map+import qualified Data.Text                 as T+import           Data.Text.Encoding        (encodeUtf8) import qualified Data.Text.Read-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Network.HTTP.Conduit as HTTP (newManager)-import qualified Network.Wai.Handler.Warp as Warp--data Config = Config-    { configDir :: F.FilePath-    , configPortMan :: PortMan.Settings-    , configHost :: HostPreference-    , configPort :: PortMan.Port-    , configSsl :: Maybe Proxy.TLSConfigNoDir-    , configSetuid :: Maybe Text-    , configReverseProxy :: Set ReverseProxy.ReverseProxyConfig-    , configIpFromHeader :: Bool-    }--instance Default Config where-    def = Config-        { configDir = "."-        , configPortMan = def-        , configHost = "*"-        , configPort = 80-        , configSsl = Nothing-        , configSetuid = Nothing-        , configReverseProxy = Set.empty-        , configIpFromHeader = False-        }+import           Data.Time                 (getCurrentTime)+import           Data.Yaml.FilePath+import qualified Filesystem                as F+import qualified Filesystem.Path.CurrentOS as F+import Filesystem.Path.CurrentOS ((</>), hasExtension)+import qualified Network.HTTP.Conduit      as HTTP (newManager)+import qualified System.FSNotify           as FSN+import           System.Posix.User         (getUserEntryForID,+                                            getUserEntryForName, userGroupID,+                                            userID, userName)+import Control.Monad (void, when)+import Data.Default (def)+import Prelude hiding (FilePath, log)+import Filesystem (listDirectory, createTree) -instance FromJSON Config where-    parseJSON (Object o) = Config-        <$> (F.fromText <$> o .: "root")-        <*> o .:? "port-manager" .!= def-        <*> (fmap fromString <$> o .:? "host") .!= configHost def-        <*> o .:? "port" .!= configPort def-        <*> o .:? "ssl"-        <*> o .:? "setuid"-        <*> o .:? "reverse-proxy" .!= Set.empty-        <*> o .:? "ip-from-header" .!= False-    parseJSON _ = mzero+keter :: FilePath -- ^ root directory or config file+      -> [FilePath -> IO Plugin]+      -> IO ()+keter input mkPlugins = withManagers input mkPlugins $ \kc hostman appMan log -> do+    launchInitial kc appMan+    startWatching kc appMan log+    startListening kc hostman -keter :: P.FilePath -- ^ root directory or config file-      -> P.IO ()-keter input' = do+-- | Load up Keter config.+withConfig :: FilePath+           -> (KeterConfig -> IO a)+           -> IO a+withConfig input f = do     exists <- F.isFile input-    Config{..} <-+    config <-         if exists-            then decodeFile input' >>= maybe (P.error "Invalid config file") return-            else return def { configDir = input }-    let dir = F.directory input F.</> configDir+            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+        (F.encodeString $ (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 <- sequence $ map ($ kconfigDir) mkPlugins     muid <--        case configSetuid of+        case kconfigSetuid of             Nothing -> return Nothing             Just t -> do                 x <- try $@@ -99,144 +108,88 @@                         Right (i, "") -> getUserEntryForID i                         _ -> getUserEntryForName $ T.unpack t                 case x of-                    Left (_ :: SomeException) -> P.error $ T.unpack $ "Invalid user ID: " ++ t+                    Left (_ :: SomeException) -> error $ "Invalid user ID: " ++ T.unpack t                     Right ue -> return $ Just (T.pack $ userName ue, (userID ue, userGroupID ue)) -    processTracker <- ProcessTracker.initProcessTracker-    portman <- runThrow $ PortMan.start configPortMan-    tf <- runThrow $ TempFolder.setup $ dir </> "temp"-    postgres <- runThrow $ Postgres.load def $ dir </> "etc" </> "postgres.yaml"-    mainlog <- runThrow $ LogFile.start $ dir </> "log" </> "keter"+    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 -    let runKIO' = runKIO $ \ml -> do-            now <- getCurrentTime-            let bs = encodeUtf8 $ T.concat-                    [ T.take 22 $ show now-                    , ": "-                    , show ml-                    , "\n"-                    ]-            runKIOPrint $ LogFile.addChunk mainlog bs-        runKIOPrint = runKIO P.print+launchInitial :: KeterConfig -> AppMan.AppManager -> IO ()+launchInitial kc@KeterConfig {..} appMan = do+    createTree incoming+    bundles0 <- fmap (filter isKeter) $ listDirectory incoming+    mapM_ (AppMan.addApp appMan) bundles0 -    manager <- HTTP.newManager def-    _ <- forkIO $ Proxy.reverseProxy-            configIpFromHeader-            manager-            Warp.defaultSettings-                { Warp.settingsPort = configPort-                , Warp.settingsHost = configHost-                }-            (runKIOPrint . PortMan.lookupPort portman)-    case configSsl of-        Nothing -> return ()-        Just (Proxy.setDir dir -> (s, ts)) -> do-            _ <- forkIO $ Proxy.reverseProxySsl-                    configIpFromHeader-                    manager-                    ts-                    s-                    (runKIOPrint . PortMan.lookupPort portman)-            return ()+    unless (V.null kconfigBuiltinStanzas) $ AppMan.perform+        appMan+        AIBuiltin+        (AppMan.Reload $ AIData $ BundleConfig kconfigBuiltinStanzas mempty)+  where+    incoming = getIncoming kc -    mappMap <- M.newMVar Map.empty-    let removeApp appname = Keter.Prelude.modifyMVar_ mappMap $ return . Map.delete appname-        addApp bundle = do-            let appname = getAppname bundle-            rest <- modifyMVar mappMap $ \appMap ->-                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 = dir </> "log" </> fromText ("app-" ++ appname)-                                direrr = dirout </> "err"-                            elfout <- LogFile.start dirout-                            case elfout of-                                Left e -> do-                                    $logEx e-                                    return Nothing-                                Right lfout -> do-                                    elferr <- LogFile.start direrr-                                    case elferr of-                                        Left e -> do-                                            $logEx e-                                            LogFile.close lfout-                                            return Nothing-                                        Right lferr -> fmap Just $ Logger.start lfout lferr-                        let logger = fromMaybe Logger.dummy mlogger-                        (app, rest) <- App.start-                            tf-                            muid-                            processTracker-                            portman-                            postgres-                            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-        terminateApp appname = do-            -- FIXME why not remove it from the map?-            appMap <- M.readMVar mappMap-            case Map.lookup appname appMap of-                Nothing -> return ()-                Just (app, _) -> runKIO' $ App.terminate app+getIncoming :: KeterConfig -> FilePath+getIncoming kc = kconfigDir kc </> "incoming" -    let incoming = dir </> "incoming"-        isKeter fp = hasExtension fp "keter"-    createTree incoming-    bundles0 <- fmap (filter isKeter) $ listDirectory incoming-    runKIO' $ mapM_ addApp bundles0+isKeter :: FilePath -> Bool+isKeter fp = hasExtension fp "keter" -    let staticReverse r = do-            PortMan.addEntry portman (ReverseProxy.reversingHost r)-                $ PortMan.PEReverseProxy-                $ ReverseProxy.RPEntry r manager-    runKIO' $ mapM_ staticReverse (Set.toList configReverseProxy)-    +startWatching :: KeterConfig -> AppMan.AppManager -> (LogMessage -> IO ()) -> IO ()+startWatching kc@KeterConfig {..} appMan log = do     -- File system watching     wm <- FSN.startManager-    FSN.watchDir wm incoming (P.const True) $ \e ->-        let e' =-                case e of-                    FSN.Removed fp _ -> Left fp-                    FSN.Added fp _ -> Right fp-                    FSN.Modified fp _ -> Right fp-         in case e' of-            Left fp -> when (isKeter fp) $ terminateApp $ getAppname fp-            Right fp -> when (isKeter fp) $ runKIO' $ addApp $ incoming </> fp+    FSN.watchDir wm incoming (const True) $ \e -> do+        e' <-+            case e of+                FSN.Removed fp _ -> do+                    log $ WatchedFile "removed" fp+                    return $ Left fp+                FSN.Added fp _ -> do+                    log $ WatchedFile "added" fp+                    return $ Right fp+                FSN.Modified fp _ -> do+                    log $ WatchedFile "modified" fp+                    return $ Right fp+        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.-    _ <- flip (installHandler sigHUP) Nothing $ Catch $ do-        actions <- M.withMVar mappMap $ \appMap -> do-            bundles <- fmap (filter isKeter) $ F.listDirectory incoming-            newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do-                time <- modificationTime <$> getFileStatus (F.encodeString bundle)-                return (getAppname' $ F.encodeString bundle, (bundle, time))+    void $ flip (installHandler sigHUP) Nothing $ Catch $ do+        bundles <- fmap (filter isKeter) $ F.listDirectory incoming+        newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do+            time <- modificationTime <$> getFileStatus (F.encodeString bundle)+            return (getAppname bundle, (bundle, time))+        AppMan.reloadAppList appMan newMap+  where+    incoming = getIncoming kc -            let apps = Set.toList $ Set.fromList (Map.keys newMap)-                        `Set.union` Set.fromList (Map.keys appMap)-            fmap catMaybes $ forM apps $ \appname -> return $-                case (Map.lookup appname appMap, Map.lookup appname newMap) of-                    (Nothing, Nothing) -> Nothing -- should never happen-                    (Just _, Nothing) -> Just $ terminateApp appname-                    (Nothing, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle-                    (Just (_, oldTime), Just (bundle, newTime))-                        | newTime /= oldTime -> Just $ runKIO' $ addApp bundle-                        | otherwise -> Nothing-        P.sequence_ actions+startListening :: KeterConfig -> HostMan.HostManager -> IO ()+startListening KeterConfig {..} hostman = do+    manager <- HTTP.newManager def+    runAndBlock kconfigListeners $ Proxy.reverseProxy+        kconfigIpFromHeader+        manager+        (HostMan.lookupAction hostman) -    runKIO' $ forever $ threadDelay $ 60 * 1000 * 1000+runAndBlock :: NonEmptyVector a+            -> (a -> IO ())+            -> IO ()+runAndBlock (NonEmptyVector x0 v) f =+    loop l0 []   where-    getAppname = either id id . toText . basename-    getAppname' = getAppname . F.decodeString-    runThrow f = runKIO P.print f >>= either throwIO return-    input = F.decodeString input'+    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

@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}+module Keter.Plugin.Postgres+    ( -- * Settings+      Settings+    , setupDBInfo+      -- * Functions+    , load+    ) where++import           Control.Applicative       ((<$>), (<*>))+import           Control.Concurrent        (forkIO)+import           Control.Concurrent.Chan+import           Control.Concurrent.MVar+import           Control.Exception         (throwIO, try)+import           Control.Monad             (void)+import           Control.Monad             (forever, mzero, replicateM)+import           Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Trans.State as S+import           Data.Default+import qualified Data.HashMap.Strict       as HMap+import qualified Data.Map                  as Map+import           Data.Monoid               ((<>))+import qualified Data.Text                 as T+import qualified Data.Text.Lazy            as TL+import           Data.Text.Lazy.Builder    (fromText, toLazyText)+import           Data.Yaml+import           Filesystem                (createTree, isFile, rename)+import           Filesystem.Path.CurrentOS (directory, encodeString, (<.>))+import           Keter.Types+import           Prelude                   hiding (FilePath)+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 <>+                    ";"+            _ <- readProcess "sudo" ["-u", "postgres", "psql"] $ TL.unpack sql+            return ()+        }++-- | Information on an individual PostgreSQL database.+data DBInfo = DBInfo+    { dbiName :: Text+    , dbiUser :: Text+    , dbiPass :: Text+    }+    deriving Show++randomDBI :: R.StdGen -> (DBInfo, R.StdGen)+randomDBI =+    S.runState (DBInfo <$> rt <*> rt <*> rt)+  where+    rt = T.pack <$> replicateM 10 (S.state $ R.randomR ('a', 'z'))++instance ToJSON DBInfo where+    toJSON (DBInfo n u p) = object+        [ "name" .= n+        , "user" .= u+        , "pass" .= p+        ]++instance FromJSON DBInfo where+    parseJSON (Object o) = DBInfo+        <$> o .: "name"+        <*> o .: "user"+        <*> o .: "pass"+    parseJSON _ = mzero++data Command = GetConfig Appname (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+    createTree $ directory fp+    e <- isFile fp+    edb <- if e+        then decodeFileEither $ encodeString 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 -> do+                case HMap.lookup "postgres" o of+                    Just (Bool True) -> do+                        x <- newEmptyMVar+                        writeChan chan $ GetConfig appname $ putMVar x+                        edbi <- takeMVar x+                        edbiToEnv edbi+                    _ -> return []+            }++    tmpfp = fp <.> "tmp"++    loop chan = do+        GetConfig appname 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 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 (encodeString tmpfp) db'+                                rename 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+        | '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", "localhost")+    , ("PGPORT", "5432")+    , ("PGUSER", dbiUser dbi)+    , ("PGPASS", dbiPass dbi)+    , ("PGDATABASE", dbiName dbi)+    ]

@@ -1,166 +0,0 @@-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Keter.PortManager
-    ( -- * Types
-      Port
-    , Host
-    , PortManager
-    , PortEntry (..)
-      -- ** Settings
-    , Settings
-    , portRange
-      -- * Actions
-    , getPort
-    , releasePort
-    , addEntry
-    , removeEntry
-    , lookupPort
-      -- * Initialize
-    , start
-    ) where
-
-import Keter.Prelude
-import qualified Control.Monad.Trans.State as S
-import Control.Monad.Trans.Class (lift)
-import qualified Data.Map as Map
-import Control.Monad (forever, mzero, mplus)
-import Data.ByteString.Char8 ()
-import qualified Network
-import qualified Data.ByteString as S
-import Data.Text.Encoding (encodeUtf8)
-import Data.Yaml (FromJSON (parseJSON), Value (Object))
-import Control.Applicative ((<$>))
-import qualified Keter.ReverseProxy as ReverseProxy (RPEntry)
-
--- | A port for an individual app to listen on.
-type Port = Int
-
--- | A virtual host we want to serve content from.
-type Host = String
-
-data Command = GetPort (Either SomeException Port -> KIO ())
-             | ReleasePort Port
-             | AddEntry Host PortEntry
-             | RemoveEntry Host
-             | AddDefaultEntry PortEntry
-             | RemoveDefaultEntry
-             | LookupPort S.ByteString (Maybe PortEntry -> KIO ())
-
--- | An abstract type which can accept commands and sends them to a background
--- nginx thread.
-newtype PortManager = PortManager (Command -> KIO ())
-
--- | Controls execution of the nginx thread. Follows the settings type pattern.
--- See: <http://www.yesodweb.com/book/settings-types>.
-data Settings = Settings
-    { portRange :: [Port]
-      -- ^ Which ports to assign to apps. Default: 4000-4999
-    }
-
-instance Default Settings where
-    def = Settings
-        { portRange = [4000..4999]
-        }
-
-instance FromJSON Settings where
-    parseJSON (Object _) = Settings
-        <$> return (portRange def)
-    parseJSON _ = mzero
-
--- | Start running a separate thread which will accept commands and modify
--- Nginx's behavior accordingly.
-start :: Settings -> KIO (Either SomeException PortManager)
-start Settings{..} = do
-    chan <- newChan
-    forkKIO $ flip S.evalStateT freshState $ forever $ do
-        command <- lift $ readChan chan
-        case command of
-            GetPort f -> do
-                ns0 <- S.get
-                let loop :: NState -> KIO (Either SomeException Port, NState)
-                    loop ns =
-                        case nsAvail ns of
-                            p:ps -> do
-                                res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p
-                                case res of
-                                    Left (_ :: SomeException) -> do
-                                        log $ RemovingPort p
-                                        loop ns { nsAvail = ps }
-                                    Right socket -> do
-                                        res' <- liftIO $ Network.sClose socket
-                                        case res' of
-                                            Left e -> do
-                                                $logEx e
-                                                log $ RemovingPort p
-                                                loop ns { nsAvail = ps }
-                                            Right () -> return (Right p, ns { nsAvail = ps })
-                            [] ->
-                                case reverse $ nsRecycled ns of
-                                    [] -> return (Left $ toException NoPortsAvailable, ns)
-                                    ps -> loop ns { nsAvail = ps, nsRecycled = [] }
-                (eport, ns) <- lift $ loop ns0
-                S.put ns
-                lift $ f eport
-            ReleasePort p ->
-                S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns }
-            AddEntry h e -> change $ Map.insert (encodeUtf8 h) e
-            RemoveEntry h -> change $ Map.delete $ encodeUtf8 h
-            AddDefaultEntry e -> S.modify $ \ns -> ns { nsDefault = Just e }
-            RemoveDefaultEntry -> S.modify $ \ns -> ns { nsDefault = Nothing }
-            LookupPort h f -> do
-                NState {..} <- S.get
-                lift $ f $ mplus (Map.lookup h nsEntries) nsDefault
-    return $ Right $ PortManager $ writeChan chan
-  where
-    change f = do
-        ns <- S.get
-        let entries = f $ nsEntries ns
-        S.put $ ns { nsEntries = entries }
-    freshState = NState portRange [] Map.empty Nothing
-
-data NState = NState
-    { nsAvail :: [Port]
-    , nsRecycled :: [Port]
-    , nsEntries :: Map.Map S.ByteString PortEntry
-    , nsDefault :: Maybe PortEntry
-    }
-
--- | Gets an unassigned port number.
-getPort :: PortManager -> KIO (Either SomeException Port)
-getPort (PortManager f) = do
-    x <- newEmptyMVar
-    f $ GetPort $ \p -> putMVar x p
-    takeMVar x
-
--- | Inform the nginx thread that the given port number is no longer being
--- used, and may be reused by a new process. 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 :: PortManager -> Port -> KIO ()
-releasePort (PortManager f) p = f $ ReleasePort p
-
--- | Add a new entry to the configuration for the given hostname and reload
--- nginx. Will overwrite any existing configuration for the given host. The
--- second point is important: it is how we achieve zero downtime transitions
--- between an old and new version of an app.
-addEntry :: PortManager -> Host -> PortEntry -> KIO ()
-addEntry (PortManager f) h p = f $ case h of
-    "*" -> AddDefaultEntry p
-    _   -> AddEntry h p
-
-data PortEntry = PEPort Port | PEStatic FilePath | PERedirect S.ByteString | PEReverseProxy ReverseProxy.RPEntry
-
--- | Remove an entry from the configuration and reload nginx.
-removeEntry :: PortManager -> Host -> KIO ()
-removeEntry (PortManager f) h = f $ case h of
-    "*" -> RemoveDefaultEntry
-    _   -> RemoveEntry h
-
-lookupPort :: PortManager -> S.ByteString -> KIO (Maybe PortEntry)
-lookupPort (PortManager f) h = do
-    x <- newEmptyMVar
-    f $ LookupPort h $ \p -> putMVar x p
-    takeMVar x

@@ -0,0 +1,70 @@+{-# 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 qualified Network+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 $ Network.listenOn $ Network.PortNumber $ fromIntegral p+                case res of+                    Left (_ :: SomeException) -> do+                        log $ RemovingPort p+                        loop next+                    Right socket -> do+                        res' <- try $ Network.sClose 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++-- | 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,151 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}-module Keter.Postgres-    ( -- * Types-      Appname-    , DBInfo (..)-    , Postgres-      -- ** Settings-    , Settings-    , setupDBInfo-      -- * Functions-    , load-    , getInfo-    ) where--import Keter.Prelude-import qualified Prelude as P-import qualified Data.Text as T-import Data.Yaml-import qualified Data.Map as Map-import Control.Monad (forever, mzero, replicateM)-import qualified Control.Monad.Trans.State as S-import Control.Monad.Trans.Class (lift)-import Control.Applicative ((<$>), (<*>))-import qualified System.Random as R-import Data.Text.Lazy.Builder (toLazyText)-import qualified Data.Text.Lazy as TL-import System.Process (readProcess)--data Settings = Settings-    { setupDBInfo :: DBInfo -> P.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 ++-                    ";"-            _ <- readProcess "sudo" ["-u", "postgres", "psql"] $ TL.unpack sql-            return ()-        }---- | Name of the application. Should just be the basename of the application--- file.-type Appname = Text---- | Information on an individual PostgreSQL database.-data DBInfo = DBInfo-    { dbiName :: Text-    , dbiUser :: Text-    , dbiPass :: Text-    }-    deriving Show--randomDBI :: R.StdGen -> (DBInfo, R.StdGen)-randomDBI =-    S.runState (DBInfo <$> rt <*> rt <*> rt)-  where-    rt = T.pack <$> replicateM 10 (S.state $ R.randomR ('a', 'z'))--instance ToJSON DBInfo where-    toJSON (DBInfo n u p) = object-        [ "name" .= n-        , "user" .= u-        , "pass" .= p-        ]--instance FromJSON DBInfo where-    parseJSON (Object o) = DBInfo-        <$> o .: "name"-        <*> o .: "user"-        <*> o .: "pass"-    parseJSON _ = mzero---- | Abstract type allowing access to config information via 'getInfo'-newtype Postgres = Postgres-    { getInfo :: Appname -> KIO (Either SomeException DBInfo)-    -- ^ Get information on an individual app\'s database information. If no-    -- information exists, it will create a random database, add it to the-    -- config file, and return it.-    }--data Command = GetConfig Appname (Either SomeException DBInfo -> KIO ())---- | 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 -> KIO (Either SomeException Postgres)-load Settings{..} fp = do-    mdb <- liftIO $ do-        createTree $ directory fp-        e <- isFile fp-        if e-            then decodeFile $ toString fp-            else return $ Just Map.empty-    case mdb of-        Left e -> return $ Left e-        Right Nothing -> return $ Left $ toException $ CannotParsePostgres fp-        Right (Just db0) -> go (db0 :: Map.Map Appname DBInfo)-  where-    go db0 = do-        chan <- newChan-        g0 <- newStdGen-        forkKIO $ flip S.evalStateT (db0, g0) $ forever $ loop chan-        return $ Right $ Postgres $ \appname -> do-            x <- newEmptyMVar-            writeChan chan $ GetConfig appname $ putMVar x-            takeMVar x--    tmpfp = fp <.> "tmp"--    loop chan = do-        GetConfig appname 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 g-                    let dbi = dbi'-                            { dbiName = sanitize appname ++ dbiName dbi'-                            , dbiUser = sanitize appname ++ dbiUser dbi'-                            }-                    ex <- lift $ liftIO $ setupDBInfo dbi-                    case ex of-                        Left e -> return $ Left e-                        Right () -> do-                            let db' = Map.insert appname dbi db-                            ey <- lift $ liftIO $ do-                                encodeFile (toString tmpfp) db'-                                rename 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-        | 'a' <= c && c <= 'z' = c-        | '0' <= c && c <= '9' = c-        | otherwise = '_'

@@ -1,314 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-module Keter.Prelude-    ( T.Text-    , String-    , P.Monad (..)-    , P.Maybe (..)-    , P.Bool (..)-    , (P.$)-    , (P..)-    , LogMessage (..)-    , log-    , logEx-    , KIO-    , toString-    , P.map-    , (A.***)-    , readFileLBS-    , P.Either (..)-    , P.either-    , E.SomeException-    , runKIO-    , void-    , liftIO-    , forkKIO-    , forkKIO'-    , (++)-    , P.minBound-    , P.succ-    , show-    , Control.Monad.when-    , fromText-    , P.flip-    , P.Show-    , KeterException (..)-    , E.toException-    , newStdGen-    , Default (..)-    , P.Int-    , (P.&&)-    , (P.==)-    , (P./=)-    , (P.*)-    , P.fromIntegral-    , P.reverse-    , P.otherwise-    , timeout-    , threadDelay-    , P.id-    , P.filter-    , P.mapM_-    , P.fmap-    , P.not-    , P.maybe-    , (P.>)-    , (P.<)-    , (P.<=)-    , (P.+)-    , (P.-)-    , getCurrentTime-      -- * Filepath-    , (F.</>)-    , (F.<.>)-    , F.FilePath-    , F.isDirectory-    , F.isFile-    , F.removeTree-    , F.createTree-    , F.directory-    , F.rename-    , F.basename-    , F.toText-    , F.hasExtension-    , F.listDirectory-    , F.decodeString-      -- * MVar-    , M.MVar-    , newMVar-    , newEmptyMVar-    , modifyMVar-    , modifyMVar_-    , swapMVar-    , takeMVar-    , tryTakeMVar-    , putMVar-      -- * IORef-    , I.IORef-    , newIORef-    , atomicModifyIORef-      -- * Chan-    , C.Chan-    , newChan-    , readChan-    , writeChan-    ) where--import qualified Filesystem.Path.CurrentOS as F-import qualified Filesystem as F-import qualified Data.Text as T-import qualified Prelude as P-import qualified Control.Arrow as A-import qualified Data.ByteString.Lazy as L-import Prelude (($), (.))-import qualified Control.Exception as E-import qualified Control.Monad-import qualified Control.Applicative-import qualified Control.Concurrent.MVar as M-import Control.Concurrent (forkIO, ThreadId)-import qualified Control.Concurrent-import qualified Data.IORef as I-import Data.Monoid (Monoid, mappend)-import qualified Data.Text.Lazy.Builder as B-import Data.Typeable (Typeable)-import qualified Control.Concurrent.Chan as C-import qualified System.Random as R-import Data.Default (Default (..))-import System.Exit (ExitCode)-import qualified Blaze.ByteString.Builder as Blaze-import qualified Blaze.ByteString.Builder.Char.Utf8-import qualified System.Timeout-import qualified Language.Haskell.TH.Syntax as TH-import qualified Data.Time--type String = T.Text--newtype KIO a = KIO { unKIO :: (LogMessage -> P.IO ()) -> P.IO a }--instance P.Monad KIO where-    return = KIO . P.const . P.return-    KIO x >>= y = KIO $ \f -> do-        x' <- x f-        let KIO mz = y x'-        mz f--instance P.Functor KIO where-    fmap = Control.Monad.liftM-instance Control.Applicative.Applicative KIO where-    (<*>) = Control.Monad.ap-    pure = P.return--log :: LogMessage -> KIO ()-log msg = do-    f <- getLogger-    void $ liftIO $ f msg-  where-    getLogger = KIO P.return--void :: P.Monad m => m a -> m ()-void f = f P.>> P.return ()--data LogMessage-    = ProcessCreated F.FilePath-    | InvalidBundle F.FilePath E.SomeException-    | ProcessDidNotStart F.FilePath-    | ExceptionThrown T.Text E.SomeException-    | RemovingPort P.Int-    | UnpackingBundle F.FilePath F.FilePath-    | TerminatingApp T.Text-    | FinishedReloading T.Text-    | TerminatingOldProcess T.Text-    | RemovingOldFolder F.FilePath-    | ReceivedInotifyEvent T.Text-    | ProcessWaiting F.FilePath--instance P.Show LogMessage where-    show (ProcessCreated f) = "Created process: " ++ F.encodeString f-    show (InvalidBundle f e) = P.concat-        [ "Unable to parse bundle file '"-        , F.encodeString f-        , "': "-        , P.show e-        ]-    show (ProcessDidNotStart fp) = P.concat-        [ "Could not start process within timeout period: "-        , F.encodeString fp-        ]-    show (ExceptionThrown t e) = P.concat-        [ T.unpack t-        , ": "-        , P.show e-        ]-    show (RemovingPort p) = "Port in use, removing from port pool: " ++ P.show p-    show (UnpackingBundle b dir) = P.concat-        [ "Unpacking bundle '"-        , F.encodeString b-        , "' into folder: "-        , F.encodeString dir-        ]-    show (TerminatingApp t) = "Shutting down app: " ++ T.unpack t-    show (FinishedReloading t) = "App finished reloading: " ++ T.unpack t-    show (TerminatingOldProcess t) = "Sending old process TERM signal: " ++ T.unpack t-    show (RemovingOldFolder fp) = "Removing unneeded folder: " ++ F.encodeString fp-    show (ReceivedInotifyEvent t) = "Received unknown INotify event: " ++ T.unpack t-    show (ProcessWaiting f) = "Process restarting too quickly, waiting before trying again: " ++ F.encodeString f--logEx :: TH.Q TH.Exp-logEx = do-    let showLoc TH.Loc { TH.loc_module = m, TH.loc_start = (l, c) } = P.concat-            [ m-            , ":"-            , P.show l-            , ":"-            , P.show c-            ]-    loc <- P.fmap showLoc TH.qLocation-    [|log P.. ExceptionThrown (T.pack $(TH.lift loc))|]--class ToString a where-    toString :: a -> P.String--instance ToString P.String where-    toString = P.id-instance ToString T.Text where-    toString = T.unpack-instance ToString F.FilePath where-    toString = F.encodeString--readFileLBS :: F.FilePath -> KIO (P.Either E.SomeException L.ByteString)-readFileLBS = liftIO . L.readFile P.. toString--liftIO :: P.IO a -> KIO (P.Either E.SomeException a)-liftIO = KIO . P.const . E.try--liftIO_ :: P.IO a -> KIO a-liftIO_ = KIO . P.const--runKIO :: (LogMessage -> P.IO ()) -> KIO a -> P.IO a-runKIO f (KIO g) = g f--newMVar :: a -> KIO (M.MVar a)-newMVar = liftIO_ . M.newMVar--newEmptyMVar :: KIO (M.MVar a)-newEmptyMVar = liftIO_ M.newEmptyMVar--modifyMVar :: M.MVar a -> (a -> KIO (a, b)) -> KIO b-modifyMVar m f = KIO $ \x -> M.modifyMVar m (\a -> unKIO (f a) x)--modifyMVar_ :: M.MVar a -> (a -> KIO a) -> KIO ()-modifyMVar_ m f = KIO $ \x -> M.modifyMVar_ m (\a -> unKIO (f a) x)--swapMVar :: M.MVar a -> a -> KIO a-swapMVar m = liftIO_ . M.swapMVar m--takeMVar :: M.MVar a -> KIO a-takeMVar = liftIO_ . M.takeMVar--tryTakeMVar :: M.MVar a -> KIO (P.Maybe a)-tryTakeMVar = liftIO_ . M.tryTakeMVar--putMVar :: M.MVar a -> a -> KIO ()-putMVar m = liftIO_ . M.putMVar m--forkKIO :: KIO () -> KIO ()-forkKIO = void . forkKIO'--forkKIO' :: KIO () -> KIO (P.Either E.SomeException ThreadId)-forkKIO' f = do-    x <- KIO P.return-    liftIO $ forkIO $ unKIO f x--newIORef :: a -> KIO (I.IORef a)-newIORef = liftIO_ . I.newIORef--atomicModifyIORef :: I.IORef a -> (a -> (a, b)) -> KIO b-atomicModifyIORef x = liftIO_ . I.atomicModifyIORef x--(++) :: Monoid m => m -> m -> m-(++) = mappend--show :: P.Show a => a -> T.Text-show = T.pack . P.show--class FromText a where-    fromText :: T.Text -> a-instance FromText T.Text where-    fromText = P.id-instance FromText F.FilePath where-    fromText = F.fromText-instance FromText B.Builder where-    fromText = B.fromText-instance FromText Blaze.Builder where-    fromText = Blaze.ByteString.Builder.Char.Utf8.fromText--data KeterException = CannotParsePostgres F.FilePath-                    | ExitCodeFailure F.FilePath ExitCode-                    | NoPortsAvailable-                    | InvalidConfigFile-    deriving (P.Show, Typeable)-instance E.Exception KeterException--newChan :: KIO (C.Chan a)-newChan = liftIO_ C.newChan--newStdGen :: KIO R.StdGen-newStdGen = liftIO_ R.newStdGen--readChan :: C.Chan a -> KIO a-readChan = liftIO_ . C.readChan--writeChan :: C.Chan a -> a -> KIO ()-writeChan c = liftIO_ . C.writeChan c--timeout :: P.Int -> KIO a -> KIO (P.Maybe a)-timeout seconds (KIO f) = KIO $ \x -> System.Timeout.timeout seconds $ f x--threadDelay :: P.Int -> KIO ()-threadDelay = liftIO_ . Control.Concurrent.threadDelay--getCurrentTime :: KIO Data.Time.UTCTime-getCurrentTime = liftIO_ Data.Time.getCurrentTime

@@ -1,92 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-module Keter.Process-    ( run-    , terminate-    , Process-    ) where--import Keter.Prelude-import Keter.ProcessTracker-import Keter.Logger (Logger, attach, LogPipes (..), mkLogPipe)-import Data.Time (diffUTCTime)-import Data.Conduit.Process.Unix (forkExecuteFile, waitForProcess, killProcess, terminateProcess)-import System.Process (ProcessHandle)-import Prelude (error)-import Data.Text.Encoding (encodeUtf8)-import Data.Conduit (($$))-import Control.Exception (onException)--data Status = NeedsRestart | NoRestart | Running ProcessHandle---- | Run the given command, restarting if the process dies.-run :: ProcessTracker-    -> Maybe Text -- ^ setuid-    -> FilePath -- ^ executable-    -> FilePath -- ^ working directory-    -> [String] -- ^ command line parameter-    -> [(String, String)] -- ^ environment-    -> Logger-    -> KIO Process-run processTracker msetuid exec dir args env logger = 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 $ ProcessWaiting exec-                                threadDelay $ 5 * 1000 * 1000-                            _ -> return ()-                        (pout, sout) <- mkLogPipe-                        (perr, serr) <- mkLogPipe-                        let cmd0 = encodeUtf8 $ either id id $ toText exec-                            args0 = map encodeUtf8 args-                            (cmd, args') =-                                case msetuid of-                                    Nothing -> (cmd0, args0)-                                    Just setuid -> ("sudo", "-E" : "-u" : encodeUtf8 setuid : "--" : cmd0 : args0)-                        res <- liftIO $ forkExecuteFile-                            cmd-                            args'-                            (Just $ map (encodeUtf8 *** encodeUtf8) env)-                            (Just $ encodeUtf8 $ either id id $ toText dir)-                            (Just $ return ())-                            (Just sout)-                            (Just serr)-                        case res of-                            Left e -> do-                                $logEx e-                                void $ liftIO $ return () $$ sout-                                void $ liftIO $ return () $$ serr-                                return (NeedsRestart, return ())-                            Right pid -> do-                                attach logger $ LogPipes pout perr-                                log $ ProcessCreated exec-                                return (Running pid, do-                                    _ <- liftIO $ do-                                        unregister <- trackProcess processTracker pid-                                        _ <- waitForProcess pid `onException` killProcess pid-                                        unregister-                                    loop (Just now))-            next-    forkKIO $ loop Nothing-    return $ Process mstatus---- | Abstract type containing information on a process which will be restarted.-newtype Process = Process (MVar Status)---- | Terminate the process and prevent it from being restarted.-terminate :: Process -> KIO ()-terminate (Process mstatus) = do-    status <- swapMVar mstatus NoRestart-    case status of-        Running pid -> do-            void $ liftIO $ terminateProcess pid-            threadDelay 1000000-            void $ liftIO $ killProcess pid-        _ -> return ()

@@ -1,36 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--- | Ensures that processes are stopped when Keter shuts down.-module Keter.ProcessTracker-    ( ProcessTracker-    , trackProcess-    , initProcessTracker-    ) where--import System.Process.Internals-import Foreign.C (CInt (..))-import System.Posix.Types (CPid (..))-import Control.Concurrent.MVar (readMVar)--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 ()--newtype ProcessTracker = ProcessTracker CInt--initProcessTracker :: IO ProcessTracker-initProcessTracker = do-    i <- c_launch_process_tracker-    if i == -1-        then error "Unable to launch process tracker"-        else return $ ProcessTracker i--trackProcess :: ProcessTracker -> ProcessHandle -> IO (IO ())-trackProcess pt (ProcessHandle mph) = do-    mpid <- readMVar mph-    case mpid of-        ClosedHandle{} -> return $ return ()-        OpenHandle pid -> do-            c_track_process pt pid 1-            return $ c_track_process pt pid 0

@@ -1,44 +1,62 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-} -- | A light-weight, minimalistic reverse HTTP proxy. module Keter.Proxy     ( reverseProxy-    , PortLookup-    , reverseProxySsl-    , setDir-    , TLSConfigNoDir+    , HostLookup+    , TLSConfig (..)     ) where -import Prelude hiding ((++), FilePath)-import Control.Monad.IO.Class (liftIO)-import Data.ByteString (ByteString)-import Keter.PortManager (PortEntry (..))-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Keter.SSL-import Network.HTTP.ReverseProxy (waiProxyToSettings, wpsSetIpHeader, SetIpHeader (..), ProxyDest (ProxyDest), WaiProxyResponse (..))-import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)-import qualified Network.Wai as Wai-import Network.HTTP.Types (status301, status200)-import qualified Keter.ReverseProxy as ReverseProxy-import Network.HTTP.Conduit (Manager)-import qualified Network.Wai.Handler.Warp as Warp-import qualified Network.Wai.Handler.WarpTLS as WarpTLS-import Blaze.ByteString.Builder (copyByteString)-import Data.Monoid (mappend)-import Data.Default+import           Blaze.ByteString.Builder          (copyByteString)+import           Control.Monad.IO.Class            (liftIO)+import qualified Data.ByteString                   as S+import qualified Data.ByteString.Char8             as S8+import           Data.Default+import           Data.Monoid                       (mappend)+import           Data.Text.Encoding                (encodeUtf8)+import qualified Data.Vector                       as V+import qualified Filesystem.Path.CurrentOS         as F+import           Keter.Types+import           Network.HTTP.Conduit              (Manager)+import           Network.HTTP.ReverseProxy         (ProxyDest (ProxyDest),+                                                    SetIpHeader (..),+                                                    WaiProxyResponse (..),+                                                    waiProxyToSettings,+                                                    wpsSetIpHeader)+import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite+import           Network.HTTP.Types                (mkStatus, status200,+                                                    status301, status302,+                                                    status303, status307,+                                                    status404)+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           Prelude                           hiding (FilePath, (++))+import           WaiAppStatic.Listing              (defaultListing)  -- | Mapping from virtual hostname to port number.-type PortLookup = ByteString -> IO (Maybe PortEntry)--reverseProxy :: Bool -> Manager -> Warp.Settings -> PortLookup -> IO ()-reverseProxy useHeader manager settings = Warp.runSettings settings . withClient useHeader manager+type HostLookup = ByteString -> IO (Maybe ProxyAction) -reverseProxySsl :: Bool -> Manager -> WarpTLS.TLSSettings -> Warp.Settings -> PortLookup -> IO ()-reverseProxySsl useHeader manager tsettings settings = WarpTLS.runTLS tsettings settings . withClient useHeader manager+reverseProxy :: Bool -> Manager -> HostLookup -> ListeningPort -> IO ()+reverseProxy useHeader manager hostLookup listener =+    run $ withClient useHeader manager hostLookup+  where+    warp host port = Warp.defaultSettings+        { Warp.settingsHost = host+        , Warp.settingsPort = port+        }+    run =+        case listener of+            LPInsecure host port -> Warp.runSettings (warp host port)+            LPSecure host port cert key -> WarpTLS.runTLS+                (WarpTLS.tlsSettings (F.encodeString cert) (F.encodeString key))+                (warp host port)  withClient :: Bool -- ^ use incoming request header for IP address            -> Manager-           -> PortLookup+           -> HostLookup            -> Wai.Application withClient useHeader manager portLookup =     waiProxyToSettings getDest def@@ -48,37 +66,80 @@                 else SIHFromSocket         } manager   where-    getDest req = do-        mport <- liftIO $ maybe (return Nothing) portLookup mhost+    getDest req =+        case lookup "host" $ Wai.requestHeaders req of+            Nothing -> return $ WPRResponse missingHostResponse+            Just host -> processHost req host++    processHost req host = do+        mport <- liftIO $ portLookup host         case mport of-            Nothing -> return $ WPRResponse $ toResponse mhost-            Just (PEPort port) -> return $ WPRProxyDest $ ProxyDest "127.0.0.1" port-            Just (PEStatic root) -> fmap WPRResponse $ staticApp (defaultFileServerSettings root) req-            Just (PERedirect host) -> return $ WPRResponse $ redirectApp host req-            Just (PEReverseProxy rpentry) -> fmap WPRResponse $ ReverseProxy.simpleReverseProxy rpentry req-      where-        mhost = lookup "host" $ Wai.requestHeaders req+            Nothing -> return $ WPRResponse $ unknownHostResponse host+            Just action -> performAction req action -redirectApp :: ByteString -> Wai.Request -> Wai.Response-redirectApp host req = Wai.responseLBS-    status301-    [("Location", dest)]-    (L.fromChunks [dest])+    performAction _ (PAPort port) =+        return $ WPRProxyDest $ ProxyDest "127.0.0.1" port+    performAction req (PAStatic StaticFilesConfig {..}) =+        fmap WPRResponse $ staticApp (defaultFileServerSettings sfconfigRoot)+            { ssListing =+                if sfconfigListings+                    then Just defaultListing+                    else Nothing+            } req+    performAction req (PARedirect config) = return $ WPRResponse $ redirectApp config req+    performAction req (PAReverseProxy config) = fmap WPRResponse $ Rewrite.simpleReverseProxy manager config req++redirectApp :: RedirectConfig -> Wai.Request -> Wai.Response+redirectApp RedirectConfig {..} req =+    V.foldr checkAction noAction redirconfigActions   where-    dest = S.concat-        [ "http://"-        , host+    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 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         ] -toResponse :: Maybe ByteString -> Wai.Response-toResponse mhost = Wai.ResponseBuilder+missingHostResponse :: Wai.Response+missingHostResponse = Wai.ResponseBuilder     status200     [("Content-Type", "text/html; charset=utf-8")]-    $ case mhost of-        Nothing -> copyByteString "<!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>"-        Just host ->-            copyByteString "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>"-            `mappend` copyByteString host-            `mappend` copyByteString "</code>, is not recognized.</p></body></html>"+    $ copyByteString "<!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>"++unknownHostResponse :: ByteString -> Wai.Response+unknownHostResponse host = Wai.ResponseBuilder+    status200+    [("Content-Type", "text/html; charset=utf-8")]+    (copyByteString "<!DOCTYPE html>\n<html><head><title>Welcome to Keter</title></head><body><h1>Welcome to Keter</h1><p>The hostname you have provided, <code>"+     `mappend` copyByteString host+     `mappend` copyByteString "</code>, is not recognized.</p></body></html>")

@@ -1,189 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Keter.ReverseProxy-  ( ReverseProxyConfig (..)-  , RewriteRule (..)-  , RPEntry (..)-  , simpleReverseProxy-  )-  where--import Control.Applicative ((<$>),(<*>),(<|>))-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 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)---- Configuration files-import Data.Yaml (FromJSON (..), Value (Object), (.:), (.:?), (.!=))-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 Data.Conduit--import qualified Network.Wai as Wai-import Network.HTTP.Conduit-import Network.HTTP.Types--data ReverseProxyConfig = ReverseProxyConfig-    { reversedHost :: Text-    , reversedPort :: Int-    , reversingHost :: Text-    , reverseUseSSL :: Bool-    , reverseTimeout :: Maybe Int-    , rewriteResponseRules :: Set RewriteRule-    , rewriteRequestRules :: Set RewriteRule-    } deriving (Eq, Ord)--instance FromJSON ReverseProxyConfig where-    parseJSON (Object o) = ReverseProxyConfig-        <$> o .: "reversed-host"-        <*> o .: "reversed-port"-        <*> o .: "reversing-host"-        <*> o .:? "ssl" .!= False-        <*> o .:? "timeout" .!= Nothing-        <*> o .:? "rewrite-response" .!= Set.empty-        <*> o .:? "rewrite-request" .!= Set.empty-    parseJSON _ = fail "Wanted an object"--instance Default ReverseProxyConfig where-    def = ReverseProxyConfig-        { reversedHost = ""-        , reversedPort = 80-        , reversingHost = ""-        , reverseUseSSL = False-        , reverseTimeout = Nothing-        , rewriteResponseRules = Set.empty-        , rewriteRequestRules = Set.empty-        }--data RewriteRule = RewriteRule-    { ruleHeader :: Text-    , ruleRegex :: Text-    , ruleReplacement :: Text-    } deriving (Eq, Ord)--instance FromJSON RewriteRule where-    parseJSON (Object o) = RewriteRule-        <$> o .: "header"-        <*> o .: "from"-        <*> o .: "to"-    parseJSON _ = fail "Wanted an object"--data RPEntry = RPEntry-    { config :: ReverseProxyConfig-    , httpManager :: Manager-    }--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 (ResourceT IO)-mkRequest rpConfig request =-  def { method = Wai.requestMethod request-      , secure = reverseUseSSL 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   -> RequestBodySourceChunked (mapOutput fromByteString $ Wai.requestBody request)-            Wai.KnownLength n -> RequestBodySource (fromIntegral n) (mapOutput fromByteString $ Wai.requestBody request)-      , decompress = const False-      , redirectCount = 0-      , checkStatus = \_ _ _ -> Nothing-      , responseTimeout = reverseTimeout rpConfig-      , cookieJar = Nothing-      }-  where-    reqRuleMap = mkRuleMap $ rewriteRequestRules rpConfig--simpleReverseProxy :: RPEntry -> Wai.Application-simpleReverseProxy (RPEntry { config = rpConfig, httpManager = mgr }) request =-  do-    let proxiedRequest = mkRequest rpConfig request-    response <- http proxiedRequest mgr-    (body, _) <- unwrapResumable $ responseBody response-    return $-      Wai.ResponseSource-        (responseStatus response)-        (rewriteHeaders respRuleMap $ responseHeaders response)-        (mapOutput (Chunk . fromByteString) body)-  where-    respRuleMap = mkRuleMap $ rewriteResponseRules rpConfig

@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Keter.SSL-    ( TLSConfigNoDir-    , setDir-    ) where--import Prelude hiding (FilePath)-import Data.Yaml (FromJSON (parseJSON), (.:), (.:?), (.!=), Value (Object))-import Control.Applicative ((<$>))-import Control.Monad (mzero)-import Data.String (fromString)-import System.FilePath ((</>))-import Filesystem.Path.CurrentOS (FilePath, encodeString)-import qualified Network.Wai.Handler.Warp as Warp-import qualified Network.Wai.Handler.WarpTLS as WarpTLS--setDir :: FilePath -> TLSConfigNoDir -> (Warp.Settings, WarpTLS.TLSSettings)-setDir dir' (TLSConfigNoDir s ts') =-    (s, ts)-  where-    dir = encodeString dir'-    ts = ts'-        { WarpTLS.certFile = dir </> WarpTLS.certFile ts'-        , WarpTLS.keyFile = dir </> WarpTLS.keyFile ts'-        }--data TLSConfigNoDir = TLSConfigNoDir !Warp.Settings !WarpTLS.TLSSettings--instance FromJSON TLSConfigNoDir where-    parseJSON (Object o) = do-        cert <- o .: "certificate"-        key <- o .: "key"-        host <- (fmap fromString <$> o .:? "host") .!= "*"-        port <- o .:? "port" .!= 443-        return $ TLSConfigNoDir-            Warp.defaultSettings-                { Warp.settingsHost = host-                , Warp.settingsPort = port-                }-            WarpTLS.defaultTlsSettings-                { WarpTLS.certFile = cert-                , WarpTLS.keyFile = key-                }-    parseJSON _ = mzero

@@ -1,41 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-module Keter.TempFolder-    ( TempFolder-    , setup-    , getFolder-    ) where--import Keter.Prelude-import Data.Word (Word)-import Keter.Postgres (Appname)-import qualified Data.IORef as I-import System.Posix.Files (setOwnerAndGroup)-import System.Posix.Types (UserID, GroupID)-import qualified Filesystem.Path.CurrentOS as F--data TempFolder = TempFolder-    { tfRoot :: FilePath-    , tfCounter :: IORef Word-    }--setup :: FilePath -> KIO (Either SomeException TempFolder)-setup fp = liftIO $ do-    e <- isDirectory fp-    when e $ removeTree fp-    createTree fp-    c <- I.newIORef minBound-    return $ TempFolder fp c--getFolder :: Maybe (UserID, GroupID) -> TempFolder -> Appname -> KIO (Either SomeException FilePath)-getFolder muid TempFolder {..} appname = do-    !i <- atomicModifyIORef tfCounter $ \i -> (succ i, i)-    let fp = tfRoot </> fromText (appname ++ "-" ++ show i)-    liftIO $ do-        createTree fp-        case muid of-            Nothing -> return ()-            Just (uid, gid) -> setOwnerAndGroup (F.encodeString fp) uid gid-        return fp

@@ -0,0 +1,23 @@+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 (..)+    , ProxyAction (..)+    , RedirectDest (..)+    , RedirectAction (..)+    , SourcePath (..)+    , ListeningPort (..)+    , AppInput (..)+    , BackgroundConfig (..)+    , RestartCount (..)+    )+import Network.HTTP.ReverseProxy.Rewrite as X (ReverseProxyConfig (..), RewriteRule (..))

@@ -0,0 +1,167 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeFamilies       #-}+module Keter.Types.Common+    ( module Keter.Types.Common+    , FilePath+    , Text+    , ByteString+    , Set+    , Map+    , Exception+    , SomeException+    ) where++import           Control.Exception          (Exception, SomeException)+import           Data.Aeson                 (Object)+import           Data.ByteString            (ByteString)+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 qualified Data.Yaml+import           Filesystem.Path.CurrentOS  (FilePath, basename, encodeString,+                                             toText)+import qualified Language.Haskell.TH.Syntax as TH+import           Prelude                    hiding (FilePath)+import           System.Exit                (ExitCode)++-- | 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 = Text++type HostBS = ByteString++getAppname :: FilePath -> Text+getAppname = either id id . toText . basename++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++instance Show LogMessage where+    show (ProcessCreated f) = "Created process: " ++ encodeString f+    show (InvalidBundle f e) = concat+        [ "Unable to parse bundle file '"+        , encodeString f+        , "': "+        , show e+        ]+    show (ProcessDidNotStart fp) = concat+        [ "Could not start process within timeout period: "+        , encodeString 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 '"+        , encodeString 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: " ++ encodeString fp+    show (ReceivedInotifyEvent t) = "Received unknown INotify event: " ++ unpack t+    show (ProcessWaiting f) = "Process restarting too quickly, waiting before trying again: " ++ encodeString 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 $ Set.toList hosts)+    show (ForgetingReservations app hosts) = "Forgeting host reservations for app " ++ show app ++ ": " ++ unwords (map unpack $ Set.toList hosts)+    show (ActivatingApp app hosts) = "Activating app " ++ show app ++ " with hosts: " ++ unwords (map unpack $ Set.toList hosts)+    show (DeactivatingApp app hosts) = "Deactivating app " ++ show app ++ " with hosts: " ++ unwords (map unpack $ Set.toList hosts)+    show (ReactivatingApp app old new) = concat+        [ "Reactivating app "+        , show app+        , ".  Old hosts: "+        , unwords (map unpack $ Set.toList old)+        , ". New hosts: "+        , unwords (map unpack $ Set.toList new)+        , "."+        ]+    show (WatchedFile action fp) = concat+        [ "Watched file "+        , unpack action+        , ": "+        , encodeString fp+        ]++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+    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

@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Legacy types from Keter version 0.4. Retained to keep backwards+-- compatibility in config file format.+module Keter.Types.V04 where++import Prelude hiding (FilePath)+import Data.Yaml.FilePath+import Data.Aeson+import Control.Applicative+import qualified Data.Set as Set+import qualified Filesystem.Path as F+import Data.Default+import Data.String (fromString)+import Data.Conduit.Network (HostPreference)+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as WarpTLS+import Filesystem.Path.CurrentOS (encodeString)+import Keter.Types.Common+import Network.HTTP.ReverseProxy.Rewrite++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+    }++instance Default KeterConfig where+    def = KeterConfig+        { kconfigDir = "."+        , kconfigPortMan = def+        , kconfigHost = "*"+        , kconfigPort = 80+        , kconfigSsl = Nothing+        , kconfigSetuid = Nothing+        , kconfigReverseProxy = Set.empty+        , kconfigIpFromHeader = False+        }++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++data TLSConfig = TLSConfig !Warp.Settings !WarpTLS.TLSSettings++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+        return $! TLSConfig+            Warp.defaultSettings+                { Warp.settingsHost = host+                , Warp.settingsPort = port+                }+            WarpTLS.defaultTlsSettings+                { WarpTLS.certFile = encodeString cert+                , WarpTLS.keyFile = encodeString key+                }++-- | 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)

@@ -0,0 +1,375 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+module Keter.Types.V10 where++import Prelude hiding (FilePath)+import           System.Posix.Types      (EpochTime)+import Data.Aeson (Object, ToJSON (..))+import Keter.Types.Common+import qualified Keter.Types.V04 as V04+import Data.Yaml.FilePath+import Data.Aeson (FromJSON (..), (.:), (.:?), Value (Object, String), withObject, (.!=))+import Control.Applicative ((<$>), (<*>), pure, (<|>))+import qualified Data.Set as Set+import qualified Filesystem.Path.CurrentOS as F+import Data.Default+import Data.String (fromString)+import Data.Conduit.Network (HostPreference)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.Monoid (mempty)+import Network.HTTP.ReverseProxy.Rewrite (ReverseProxyConfig)+import Data.Maybe (fromMaybe, catMaybes)+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as WarpTLS+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map as Map+import Data.Aeson ((.=), Value (Bool), object)+import Data.Word (Word)++data BundleConfig = BundleConfig+    { bconfigStanzas :: !(Vector (Stanza ()))+    , bconfigPlugins :: !Object -- ^ settings used for plugins+    }++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 (StanzaWebApp . toCurrent) webapp+            , V.fromList $ map (StanzaStaticFiles . toCurrent) $ Set.toList statics+            , V.fromList $ map (StanzaRedirect . toCurrent) $ Set.toList redirs+            ]+        , bconfigPlugins =+            case webapp >>= HashMap.lookup "postgres" . V04.configRaw of+                Just (Bool True) -> HashMap.singleton "postgres" (Bool True)+                _ -> HashMap.empty+        }++instance ParseYamlFile BundleConfig where+    parseYamlFile basedir = withObject "BundleConfig" $ \o -> do+        case HashMap.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" .!= HashMap.empty++instance ToJSON BundleConfig where+    toJSON BundleConfig {..} = object+        [ "stanzas" .= bconfigStanzas+        , "plugins" .= bconfigPlugins+        ]++data ListeningPort = LPSecure !HostPreference !Port !F.FilePath !F.FilePath+                   | 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"+        case (mcert, mkey) of+            (Nothing, Nothing) -> do+                port <- o .:? "port" .!= 80+                return $ LPInsecure host port+            (Just cert, Just key) -> do+                port <- o .:? "port" .!= 443+                return $ LPSecure host port cert key+            _ -> 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+    }++instance ToCurrent KeterConfig where+    type Previous KeterConfig = V04.KeterConfig+    toCurrent (V04.KeterConfig dir portman host port ssl setuid rproxy ipFromHeader) = KeterConfig+        { kconfigDir = dir+        , kconfigPortPool = portman+        , kconfigListeners = NonEmptyVector (LPInsecure host port) (getSSL ssl)+        , kconfigSetuid = setuid+        , kconfigBuiltinStanzas = V.fromList $ map StanzaReverseProxy $ Set.toList rproxy+        , kconfigIpFromHeader = ipFromHeader+        }+      where+        getSSL Nothing = V.empty+        getSSL (Just (V04.TLSConfig s ts)) = V.singleton $ LPSecure+            (Warp.settingsHost s)+            (Warp.settingsPort s)+            (F.decodeString $ WarpTLS.certFile ts)+            (F.decodeString $ WarpTLS.keyFile ts)++instance Default KeterConfig where+    def = KeterConfig+        { kconfigDir = "."+        , kconfigPortPool = def+        , kconfigListeners = NonEmptyVector (LPInsecure "*" 80) V.empty+        , kconfigSetuid = Nothing+        , kconfigBuiltinStanzas = V.empty+        , kconfigIpFromHeader = False+        }++instance ParseYamlFile KeterConfig where+    parseYamlFile basedir = withObject "KeterConfig" $ \o ->+        case HashMap.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++data Stanza port+    = StanzaStaticFiles !StaticFilesConfig+    | StanzaRedirect !RedirectConfig+    | StanzaWebApp !(WebAppConfig port)+    | StanzaReverseProxy !ReverseProxyConfig+    | 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 ProxyAction = PAPort Port+                 | PAStatic StaticFilesConfig+                 | PARedirect RedirectConfig+                 | PAReverseProxy ReverseProxyConfig+    deriving Show++instance ParseYamlFile (Stanza ()) where+    parseYamlFile basedir = withObject "Stanza" $ \o -> do+        typ <- o .: "type"+        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" -> fmap StanzaReverseProxy $ parseJSON $ Object o+            "background" -> fmap StanzaBackground $ parseYamlFile basedir $ Object o+            _ -> fail $ "Unknown stanza type: " ++ typ++instance ToJSON (Stanza ()) 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 t x =+    case toJSON x of+        Object o -> Object $ HashMap.insert "type" t o+        v -> v++data StaticFilesConfig = StaticFilesConfig+    { sfconfigRoot     :: !F.FilePath+    , sfconfigHosts    :: !(Set Host)+    , sfconfigListings :: !Bool+    -- FIXME basic auth+    }+    deriving Show++instance ToCurrent StaticFilesConfig where+    type Previous StaticFilesConfig = V04.StaticHost+    toCurrent (V04.StaticHost host root) = StaticFilesConfig+        { sfconfigRoot = root+        , sfconfigHosts = Set.singleton host+        , sfconfigListings = True+        }++instance ParseYamlFile StaticFilesConfig where+    parseYamlFile basedir = withObject "StaticFilesConfig" $ \o -> StaticFilesConfig+        <$> lookupBase basedir o "root"+        <*> (o .: "hosts" <|> (Set.singleton <$> (o .: "host")))+        <*> o .:? "directory-listing" .!= False++instance ToJSON StaticFilesConfig where+    toJSON StaticFilesConfig {..} = object+        [ "root" .= F.encodeString sfconfigRoot+        , "hosts" .= sfconfigHosts+        , "directory-listing" .= sfconfigListings+        ]++data RedirectConfig = RedirectConfig+    { redirconfigHosts :: !(Set Host)+    , redirconfigStatus :: !Int+    , redirconfigActions :: !(Vector RedirectAction)+    }+    deriving Show++instance ToCurrent RedirectConfig where+    type Previous RedirectConfig = V04.Redirect+    toCurrent (V04.Redirect from to) = RedirectConfig+        { redirconfigHosts = Set.singleton from+        , redirconfigStatus = 301+        , redirconfigActions = V.singleton $ RedirectAction SPAny+                             $ RDPrefix False to Nothing+        }++instance ParseYamlFile RedirectConfig where+    parseYamlFile _ = withObject "RedirectConfig" $ \o -> RedirectConfig+        <$> (o .: "hosts" <|> (Set.singleton <$> (o .: "host")))+        <*> o .:? "status" .!= 303+        <*> o .: "actions"++instance ToJSON RedirectConfig where+    toJSON RedirectConfig {..} = object+        [ "hosts" .= redirconfigHosts+        , "status" .= redirconfigStatus+        , "actions" .= redirconfigActions+        ]++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 $ HashMap.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+            <*> 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" .= 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 :: !Text -- ^ primary host, used for approot+    , waconfigHosts       :: !(Set Text) -- ^ all hosts, not including the approot host+    , waconfigSsl         :: !Bool+    , waconfigPort        :: !port+    }+    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 = host+        , waconfigHosts = hosts+        , waconfigSsl = ssl+        , waconfigPort = ()+        }++instance ParseYamlFile (WebAppConfig ()) where+    parseYamlFile basedir = withObject "WebAppConfig" $ \o -> do+        (ahost, hosts) <-+            (do+                h <- o .: "host"+                return (h, Set.empty)) <|>+            (do+                hs <- o .: "hosts"+                case hs of+                    [] -> fail "Must provide at least one host"+                    h:hs' -> return (h, Set.fromList hs'))+        WebAppConfig+            <$> lookupBase basedir o "exec"+            <*> o .:? "args" .!= V.empty+            <*> o .:? "env" .!= Map.empty+            <*> return ahost+            <*> return hosts+            <*> o .:? "ssl" .!= False+            <*> return ()++instance ToJSON (WebAppConfig ()) where+    toJSON WebAppConfig {..} = object+        [ "exec" .= F.encodeString waconfigExec+        , "args" .= waconfigArgs+        , "env" .= waconfigEnvironment+        , "hosts" .= (waconfigApprootHost : Set.toList waconfigHosts)+        , "ssl" .= waconfigSsl+        ]++data AppInput = AIBundle !FilePath !EpochTime+              | AIData !BundleConfig++data BackgroundConfig = BackgroundConfig+    { bgconfigExec :: !F.FilePath+    , bgconfigArgs :: !(Vector Text)+    , bgconfigEnvironment :: !(Map Text Text)+    , bgconfigRestartCount :: !RestartCount+    , bgconfigRestartDelaySeconds :: !Word+    }+    deriving Show++data RestartCount = UnlimitedRestarts | LimitedRestarts !Word+    deriving Show++instance FromJSON RestartCount where+    parseJSON (String "unlimited") = return UnlimitedRestarts+    parseJSON v = fmap 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++instance ToJSON BackgroundConfig where+    toJSON BackgroundConfig {..} = object $ catMaybes+        [ Just $ "exec" .= F.encodeString bgconfigExec+        , Just $ "args" .= bgconfigArgs+        , Just $ "env" .= bgconfigEnvironment+        , case bgconfigRestartCount of+            UnlimitedRestarts -> Nothing+            LimitedRestarts count -> Just $ "restart-count" .= count+        , Just $ "restart-delay-seconds" .= bgconfigRestartDelaySeconds+        ]

@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.HTTP.ReverseProxy.Rewrite+  ( ReverseProxyConfig (..)+  , RewriteRule (..)+  , RPEntry (..)+  , simpleReverseProxy+  )+  where++import Control.Applicative+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 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)++-- 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 Data.Conduit++import qualified Network.Wai as Wai+import Network.HTTP.Conduit+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 (ResourceT IO)+mkRequest rpConfig request =+  def { method = Wai.requestMethod request+      , secure = reverseUseSSL 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   -> RequestBodySourceChunked (mapOutput fromByteString $ Wai.requestBody request)+            Wai.KnownLength n -> RequestBodySource (fromIntegral n) (mapOutput fromByteString $ Wai.requestBody request)+      , decompress = const False+      , redirectCount = 0+      , checkStatus = \_ _ _ -> Nothing+      , responseTimeout = reverseTimeout rpConfig+      , cookieJar = Nothing+      }+  where+    reqRuleMap = mkRuleMap $ rewriteRequestRules rpConfig++simpleReverseProxy :: Manager -> ReverseProxyConfig -> Wai.Application+simpleReverseProxy mgr rpConfig request =+  do+    let proxiedRequest = mkRequest rpConfig request+    response <- http proxiedRequest mgr+    (body, _) <- unwrapResumable $ responseBody response+    return $+      Wai.ResponseSource+        (responseStatus response)+        (rewriteHeaders respRuleMap $ responseHeaders response)+        (mapOutput (Chunk . fromByteString) body)+  where+    respRuleMap = mkRuleMap $ rewriteResponseRules rpConfig++data ReverseProxyConfig = ReverseProxyConfig+    { reversedHost :: Text+    , reversedPort :: Int+    , reversingHost :: Text+    , reverseUseSSL :: Bool+    , 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 .: "reversing-host"+        <*> o .:? "ssl" .!= False+        <*> 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+        , "reversing-host" .= reversingHost+        , "ssl" .= reverseUseSSL+        , "timeout" .= reverseTimeout+        , "rewrite-response" .= rewriteResponseRules+        , "rewrite-request" .= rewriteRequestRules+        ]++instance Default ReverseProxyConfig where+    def = ReverseProxyConfig+        { reversedHost = ""+        , reversedPort = 80+        , reversingHost = ""+        , reverseUseSSL = False+        , 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,100 +0,0 @@-#include <unistd.h>-#include <stdlib.h>-#include <stdio.h>-#include <signal.h>--struct node {-    pid_t pid;-    struct node *next;-};--static struct node * add_node(pid_t pid, struct node *n) {-    struct node *n2 = malloc(sizeof(struct node));-    n2->pid = pid;-    n2->next = n;-    return n2;-}--static struct node * remove_node(pid_t pid, struct node *n) {-    if (!n) {-        return n;-    }-    else if (n->pid == pid) {-        struct node *n2 = n->next;-        free(n);-        return remove_node(pid, n2);-    }-    else {-        n->next = remove_node(pid, n->next);-        return n;-    }-}--extern void track_process(int fd, pid_t pid, int b) {-    unsigned int buffer[2];--    //printf("Tracking process %d, %d\n", pid, b);--    buffer[0] = pid;-    buffer[1] = b;-    if (! write(fd, buffer, sizeof(unsigned int) * 2)) {-        //printf("Error writing to fd %d\n", fd);-    }-}--// Returns FD to write to, or -1 on failure.-extern int launch_process_tracker(void) {-    int pipes[2];-    pid_t child;--    if (pipe(pipes)) {-        return -1;-    }--    child = fork();--    if (child < 0) {-        return -1;-    }-    else if (child == 0) {-        unsigned int buffer[2];-        struct node *n = 0, *n2;--        close(pipes[1]);--        // Prevent monitoring programs like Upstart from killing this-        // new process along with the parent-        setpgid(0, 0);--        while (read(pipes[0], buffer, sizeof(unsigned int) * 2) > 0) {-            if (buffer[1]) {-                //printf("Adding node %d\n", buffer[0]);-                n = add_node(buffer[0], n);-            }-            else {-                //printf("Removing node %d\n", buffer[0]);-                n = remove_node(buffer[0], n);-            }-        }--        for (n2 = n; n2; n2 = n2->next) {-            //printf("Sending process %d TERM signal\n", n2->pid);-            kill(n2->pid, SIGTERM);-        }--        sleep(2);--        while (n) {-            //printf("Sending process %d KILL signal\n", n->pid);-            kill(n2->pid, SIGKILL);--            n2 = n;-            n = n->next;-            free(n2);-        }-    }-    else {-        close(pipes[0]);-        return pipes[1];-    }-}

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+import System.Environment+import qualified Data.ByteString.Lazy.Char8 as L8+import Network.Wai+import Network.Wai.Handler.Warp+import Network.HTTP.Types+import System.Directory+import Control.Monad.IO.Class+import System.IO+import Network.Wai.Middleware.RequestLogger+import Data.Default++main :: IO ()+main = do+    fp <- canonicalizePath "."+    [msg] <- getArgs+    portS <- getEnv "PORT"+    env <- getEnvironment+    let port = read portS+    logger <- mkRequestLogger def+        { outputFormat = Apache FromHeader+        }+    run port $ logger $ \req -> do+        liftIO $ putStrLn $ "Received a request at: " ++ show (pathInfo req)+        liftIO $ hFlush stdout+        liftIO $ hPutStrLn stderr $ "Testing standard error"+        liftIO $ hFlush stderr+        return $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack $ unlines+            $ ("Message: " ++ msg)+            : ("Path: " ++ fp)+            : ("Headers: " ++ show (requestHeaders req))+            : map (\(k, v) -> concat+                [ "Env: "+                , k+                , " = "+                , v+                ]) env

@@ -1,11 +1,15 @@ Name:                keter-Version:             0.4.0+Version:             1.0.1 Synopsis:            Web application deployment manager, focusing on Haskell web frameworks Description:     Handles deployment of web apps, providing a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: <https://github.com/snoyberg/keter#readme>     .     Release history:     .+    [1.0.1] Permit use of wildcard subdomains and exceptions to wildcards. Convert internal strings to use Data.Text in more places. (Although internationalized domain names are not supported unless entered in punycode in configuration files.)+    .+    [1.0.0] Significant overhaul. We now support monitoring of much more arbitrary jobs (e.g., background tasks), have a proper plugin system (PostgreSQL is no longer a required component), and have a much better system for tracking hostname mapping changes.+    .     [0.4.0] Switch to fsnotify to get cross-platform support. No longer using raw proxies, but instead WAI proxies.     .     [0.3.7] Sending a HUP signal reloads the list of deployed apps. This is useful for circumstances where inotify does not work correctly, such as on file systems which do not support it.@@ -20,6 +24,8 @@ Build-type:          Simple Cabal-version:       >=1.8 +--Data-Files:        incoming/foo/bundle.sh, incoming/foo/config/keter.yaml+ Library   Build-depends:       base                      >= 4             && < 5                      , directory@@ -37,7 +43,7 @@                      , tar                       >= 0.4                      , template-haskell                      , blaze-builder             >= 0.3           && < 0.4-                     , yaml                      >= 0.7           && < 0.9+                     , yaml                      >= 0.8.4         && < 0.9                      , unix-compat               >= 0.3           && < 0.5                      , fsnotify                  >= 0.0.11                      , system-filepath           >= 0.4           && < 0.5@@ -46,7 +52,7 @@                      , network-conduit           >= 0.6                      , network-conduit-tls       >= 1.0.0.2                      , http-reverse-proxy        >= 0.2           && < 0.3-                     , unix-process-conduit      >= 0.2           && < 0.3+                     , unix-process-conduit      >= 0.2.2         && < 0.3                      , unix                      >= 2.5           && < 2.7                      , wai-app-static            >= 1.3           && < 1.4                      , wai                       >= 1.4           && < 1.5@@ -59,28 +65,50 @@                      , mtl                      , warp                      , warp-tls-  Exposed-Modules:     Keter.Process-                       Keter.ProcessTracker-                       Keter.Postgres-                       Keter.TempFolder+                     , aeson+                     , unordered-containers+                     , vector+                     , stm+                     , async+  Exposed-Modules:     Keter.Plugin.Postgres+                       Keter.Types+                       Keter.Types.V04+                       Keter.Types.V10+                       Keter.Types.Common                        Keter.App+                       Keter.AppManager+                       Keter.LabelMap                        Keter.Main-                       Keter.Prelude-                       Keter.LogFile-                       Keter.Logger+                       Keter.PortPool                        Keter.Proxy-                       Keter.PortManager-                       Keter.SSL-                       Keter.ReverseProxy-  c-sources:           cbits/process-tracker.c+                       Keter.HostManager+                       Network.HTTP.ReverseProxy.Rewrite+                       Data.Yaml.FilePath+                       Codec.Archive.TempTarball   ghc-options:         -Wall  Executable keter   Main-is:             keter.hs   hs-source-dirs:      main-  Build-depends:       base, keter+  Build-depends:       base, keter, system-filepath, data-default   ghc-options:         -threaded -Wall   other-modules:       Paths_keter++Executable hello+  Main-is:             hello.hs+  hs-source-dirs:      incoming/foo+  Build-depends:       base+                     , keter+                     , warp+                     , wai+                     , wai-extra+                     , http-types+                     , bytestring+                     , directory+                     , data-default+                     , transformers+  ghc-options:         -threaded -Wall+  buildable: False  source-repository head   type:     git

@@ -1,16 +1,22 @@ {-# 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 Filesystem.Path.CurrentOS ((</>), decodeString)  main :: IO () main = do     args <- getArgs     case args of         ["--version"] -> putStrLn $ "keter version: " ++ showVersion version-        [dir] -> keter dir+        [dir] -> keter+            (decodeString dir)+            [\configDir -> Postgres.load def $ configDir </> "etc" </> "postgres.yaml"]         _ -> do             pn <- getProgName             error $ "Usage: " ++ pn ++ " <root folder>"