2012-05-11 08:38:05 +04:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2012-05-15 12:19:03 +04:00
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
2012-05-17 10:32:11 +04:00
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
2012-10-14 20:17:01 +04:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
2012-05-11 08:38:05 +04:00
|
|
|
module Keter.App
|
|
|
|
( App
|
|
|
|
, start
|
|
|
|
, reload
|
|
|
|
, Keter.App.terminate
|
|
|
|
) where
|
|
|
|
|
2013-07-10 14:26:37 +04:00
|
|
|
import Prelude (IO, Eq, Ord, fst, snd, concat, mapM)
|
2012-05-15 12:19:03 +04:00
|
|
|
import Keter.Prelude
|
2013-07-10 15:15:18 +04:00
|
|
|
import Codec.Archive.TempTarball
|
2012-05-11 08:38:05 +04:00
|
|
|
import Keter.Process
|
2013-07-10 14:26:37 +04:00
|
|
|
import Keter.Types
|
2012-08-06 18:44:41 +04:00
|
|
|
import Keter.PortManager hiding (start)
|
2012-05-14 11:15:50 +04:00
|
|
|
import qualified Filesystem.Path.CurrentOS as F
|
2012-05-11 08:38:05 +04:00
|
|
|
import Data.Yaml
|
2013-01-28 11:09:02 +04:00
|
|
|
import Control.Applicative ((<$>), (<*>), (<|>), pure)
|
2012-05-11 08:38:05 +04:00
|
|
|
import qualified Network
|
2012-10-14 20:17:01 +04:00
|
|
|
import Data.Maybe (fromMaybe, mapMaybe)
|
2013-07-10 15:09:14 +04:00
|
|
|
import Control.Exception (throwIO)
|
2012-05-11 08:38:05 +04:00
|
|
|
import System.IO (hClose)
|
2012-10-12 14:17:00 +04:00
|
|
|
import Data.Set (Set)
|
|
|
|
import qualified Data.Set as Set
|
2012-10-21 09:07:26 +04:00
|
|
|
import Data.Text.Encoding (encodeUtf8)
|
2012-10-24 18:31:18 +04:00
|
|
|
import System.Posix.Types (UserID, GroupID)
|
2013-07-10 13:48:46 +04:00
|
|
|
import Data.Conduit.Process.Unix (ProcessTracker, RotatingLog)
|
2012-05-11 08:38:05 +04:00
|
|
|
|
2013-01-28 11:09:02 +04:00
|
|
|
data AppConfig = AppConfig
|
2012-05-14 11:15:50 +04:00
|
|
|
{ configExec :: F.FilePath
|
|
|
|
, configArgs :: [Text]
|
2013-01-28 11:09:02 +04:00
|
|
|
, configHost :: Text
|
2012-09-14 07:29:03 +04:00
|
|
|
, configSsl :: Bool
|
2012-10-12 14:17:00 +04:00
|
|
|
, configExtraHosts :: Set String
|
2013-07-10 14:26:37 +04:00
|
|
|
, configRaw :: Object
|
2012-05-11 08:38:05 +04:00
|
|
|
}
|
|
|
|
|
2013-01-28 11:09:02 +04:00
|
|
|
instance FromJSON AppConfig where
|
|
|
|
parseJSON (Object o) = AppConfig
|
2012-05-14 11:15:50 +04:00
|
|
|
<$> (F.fromText <$> o .: "exec")
|
2012-05-11 08:38:05 +04:00
|
|
|
<*> o .:? "args" .!= []
|
|
|
|
<*> o .: "host"
|
2012-09-14 07:29:03 +04:00
|
|
|
<*> o .:? "ssl" .!= False
|
2012-10-12 14:17:00 +04:00
|
|
|
<*> o .:? "extra-hosts" .!= Set.empty
|
2013-07-10 14:26:37 +04:00
|
|
|
<*> return o
|
2013-01-28 11:09:02 +04:00
|
|
|
parseJSON _ = fail "Wanted an object"
|
|
|
|
|
|
|
|
data Config = Config
|
|
|
|
{ configApp :: Maybe AppConfig
|
|
|
|
, configStaticHosts :: Set StaticHost
|
|
|
|
, configRedirects :: Set Redirect
|
|
|
|
}
|
|
|
|
|
|
|
|
instance FromJSON Config where
|
|
|
|
parseJSON (Object o) = Config
|
|
|
|
<$> ((Just <$> parseJSON (Object o)) <|> pure Nothing)
|
2012-10-14 20:17:01 +04:00
|
|
|
<*> o .:? "static-hosts" .!= Set.empty
|
2012-10-21 09:07:26 +04:00
|
|
|
<*> o .:? "redirects" .!= Set.empty
|
2012-10-14 20:17:01 +04:00
|
|
|
parseJSON _ = fail "Wanted an object"
|
|
|
|
|
|
|
|
data StaticHost = StaticHost
|
|
|
|
{ shHost :: String
|
|
|
|
, shRoot :: FilePath
|
|
|
|
}
|
|
|
|
deriving (Eq, Ord)
|
|
|
|
|
|
|
|
instance FromJSON StaticHost where
|
|
|
|
parseJSON (Object o) = StaticHost
|
|
|
|
<$> o .: "host"
|
|
|
|
<*> (F.fromText <$> o .: "root")
|
2012-05-11 08:38:05 +04:00
|
|
|
parseJSON _ = fail "Wanted an object"
|
|
|
|
|
2012-10-21 09:07:26 +04:00
|
|
|
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"
|
|
|
|
|
2012-05-11 08:38:05 +04:00
|
|
|
data Command = Reload | Terminate
|
2012-05-15 12:19:03 +04:00
|
|
|
newtype App = App (Command -> KIO ())
|
2012-05-11 08:38:05 +04:00
|
|
|
|
|
|
|
unpackBundle :: TempFolder
|
2012-10-24 18:31:18 +04:00
|
|
|
-> Maybe (UserID, GroupID)
|
2012-05-14 11:15:50 +04:00
|
|
|
-> F.FilePath
|
2012-05-11 08:38:05 +04:00
|
|
|
-> Appname
|
2012-05-15 12:19:03 +04:00
|
|
|
-> KIO (Either SomeException (FilePath, Config))
|
2012-10-24 18:31:18 +04:00
|
|
|
unpackBundle tf muid bundle appname = do
|
2013-07-10 15:09:14 +04:00
|
|
|
log $ UnpackingBundle bundle
|
|
|
|
liftIO $ unpackTempTar muid tf bundle appname $ \dir -> do
|
|
|
|
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
|
|
|
|
})
|
2012-05-11 08:38:05 +04:00
|
|
|
|
2012-10-12 14:59:46 +04:00
|
|
|
-- | Ensures that the given path does not escape the containing folder and sets
|
|
|
|
-- the pathname based on config file location.
|
2012-10-14 20:17:01 +04:00
|
|
|
fixStaticHost :: FilePath -> StaticHost -> Maybe StaticHost
|
|
|
|
fixStaticHost dir sh =
|
2012-10-12 14:59:46 +04:00
|
|
|
case (F.stripPrefix (F.collapse dir F.</> "") fp, F.relative fp0) of
|
2012-10-14 20:17:01 +04:00
|
|
|
(Just _, True) -> Just sh { shRoot = fp }
|
2012-10-12 14:59:46 +04:00
|
|
|
_ -> Nothing
|
|
|
|
where
|
2012-10-14 20:17:01 +04:00
|
|
|
fp0 = shRoot sh
|
2012-10-12 14:59:46 +04:00
|
|
|
fp = F.collapse $ dir F.</> "config" F.</> fp0
|
|
|
|
|
2012-05-11 08:38:05 +04:00
|
|
|
start :: TempFolder
|
2012-10-24 18:31:18 +04:00
|
|
|
-> Maybe (Text, (UserID, GroupID))
|
2012-11-19 12:31:35 +04:00
|
|
|
-> ProcessTracker
|
2012-08-06 18:44:41 +04:00
|
|
|
-> PortManager
|
2013-07-10 14:26:37 +04:00
|
|
|
-> Plugins
|
2013-07-10 13:48:46 +04:00
|
|
|
-> RotatingLog
|
2012-05-11 12:29:25 +04:00
|
|
|
-> Appname
|
2012-05-14 11:15:50 +04:00
|
|
|
-> F.FilePath -- ^ app bundle
|
2012-05-15 12:19:03 +04:00
|
|
|
-> KIO () -- ^ action to perform to remove this App from list of actives
|
|
|
|
-> KIO (App, KIO ())
|
2013-07-10 14:26:37 +04:00
|
|
|
start tf muid processTracker portman plugins rlog appname bundle removeFromList = do
|
2012-05-15 12:19:03 +04:00
|
|
|
chan <- newChan
|
|
|
|
return (App $ writeChan chan, rest chan)
|
2012-05-11 08:38:05 +04:00
|
|
|
where
|
|
|
|
runApp port dir config = do
|
2013-07-10 14:26:37 +04:00
|
|
|
otherEnv <- pluginsGetEnv plugins appname (configRaw config)
|
2012-05-17 10:32:11 +04:00
|
|
|
let env = ("PORT", show port)
|
2012-09-14 07:46:13 +04:00
|
|
|
: ("APPROOT", (if configSsl config then "https://" else "http://") ++ configHost config)
|
2012-05-17 10:32:11 +04:00
|
|
|
: otherEnv
|
2012-05-15 12:19:03 +04:00
|
|
|
run
|
2012-11-19 12:31:35 +04:00
|
|
|
processTracker
|
2012-10-24 18:31:18 +04:00
|
|
|
(fst <$> muid)
|
2012-05-15 12:19:03 +04:00
|
|
|
("config" </> configExec config)
|
|
|
|
dir
|
2012-05-11 08:38:05 +04:00
|
|
|
(configArgs config)
|
2012-05-17 10:32:11 +04:00
|
|
|
env
|
2013-07-10 13:48:46 +04:00
|
|
|
rlog
|
2012-05-11 08:38:05 +04:00
|
|
|
|
2012-05-15 12:19:03 +04:00
|
|
|
rest chan = forkKIO $ do
|
2012-10-24 18:31:18 +04:00
|
|
|
mres <- unpackBundle tf (snd <$> muid) bundle appname
|
2012-05-11 08:38:05 +04:00
|
|
|
case mres of
|
2012-05-15 12:19:03 +04:00
|
|
|
Left e -> do
|
2012-05-17 10:32:11 +04:00
|
|
|
$logEx e
|
2012-05-15 12:19:03 +04:00
|
|
|
removeFromList
|
|
|
|
Right (dir, config) -> do
|
2013-01-28 11:09:02 +04:00
|
|
|
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
|
|
|
|
Nothing -> do
|
|
|
|
common
|
|
|
|
loop chan dir config Nothing
|
|
|
|
Just appconfig -> do
|
|
|
|
eport <- getPort portman
|
|
|
|
case eport of
|
|
|
|
Left e -> do
|
|
|
|
$logEx e
|
2012-05-15 11:49:20 +04:00
|
|
|
removeFromList
|
2013-01-28 11:09:02 +04:00
|
|
|
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
|
|
|
|
removeFromList
|
|
|
|
releasePort portman port
|
|
|
|
Keter.Process.terminate process
|
2012-05-11 08:38:05 +04:00
|
|
|
|
2013-01-28 11:09:02 +04:00
|
|
|
loop chan dirOld configOld mprocPortOld = do
|
2012-05-15 12:19:03 +04:00
|
|
|
command <- readChan chan
|
2012-05-11 08:38:05 +04:00
|
|
|
case command of
|
|
|
|
Terminate -> do
|
|
|
|
removeFromList
|
2013-01-28 11:09:02 +04:00
|
|
|
case configApp configOld of
|
|
|
|
Nothing -> return ()
|
|
|
|
Just appconfig -> do
|
|
|
|
removeEntry portman $ configHost appconfig
|
|
|
|
mapM_ (removeEntry portman) $ Set.toList $ configExtraHosts appconfig
|
2012-10-14 20:17:01 +04:00
|
|
|
mapM_ (removeEntry portman) $ map shHost $ Set.toList $ configStaticHosts configOld
|
2012-10-21 09:07:26 +04:00
|
|
|
mapM_ (removeEntry portman) $ map redFrom $ Set.toList $ configRedirects configOld
|
2012-05-15 12:19:03 +04:00
|
|
|
log $ TerminatingApp appname
|
2012-05-11 08:38:05 +04:00
|
|
|
terminateOld
|
|
|
|
Reload -> do
|
2012-10-24 18:31:18 +04:00
|
|
|
mres <- unpackBundle tf (snd <$> muid) bundle appname
|
2012-05-11 08:38:05 +04:00
|
|
|
case mres of
|
2012-05-15 12:19:03 +04:00
|
|
|
Left e -> do
|
|
|
|
log $ InvalidBundle bundle e
|
2013-01-28 11:09:02 +04:00
|
|
|
loop chan dirOld configOld mprocPortOld
|
2012-05-15 12:19:03 +04:00
|
|
|
Right (dir, config) -> do
|
2012-08-06 18:44:41 +04:00
|
|
|
eport <- getPort portman
|
2012-05-15 11:49:20 +04:00
|
|
|
case eport of
|
2012-05-17 10:32:11 +04:00
|
|
|
Left e -> $logEx e
|
2012-05-15 11:49:20 +04:00
|
|
|
Right port -> do
|
2013-01-28 11:09:02 +04:00
|
|
|
let common = do
|
2012-10-21 09:07:26 +04:00
|
|
|
mapM_ (\StaticHost{..} -> addEntry portman shHost (PEStatic shRoot)) $ Set.toList $ configStaticHosts config
|
|
|
|
mapM_ (\Redirect{..} -> addEntry portman redFrom (PERedirect $ encodeUtf8 redTo)) $ Set.toList $ configRedirects config
|
2013-01-28 11:09:02 +04:00
|
|
|
case configApp 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
|
|
|
|
common
|
|
|
|
case configApp configOld of
|
|
|
|
Just appconfigOld | configHost appconfig /= configHost appconfigOld ->
|
|
|
|
removeEntry portman $ configHost appconfigOld
|
|
|
|
_ -> return ()
|
|
|
|
log $ FinishedReloading appname
|
|
|
|
terminateOld
|
|
|
|
loop chan dir config $ Just (process, port)
|
|
|
|
else do
|
|
|
|
releasePort portman port
|
|
|
|
Keter.Process.terminate process
|
|
|
|
log $ ProcessDidNotStart bundle
|
|
|
|
loop chan dirOld configOld mprocPortOld
|
2012-05-11 08:38:05 +04:00
|
|
|
where
|
2012-05-15 12:19:03 +04:00
|
|
|
terminateOld = forkKIO $ do
|
2012-05-11 08:38:05 +04:00
|
|
|
threadDelay $ 20 * 1000 * 1000
|
2012-05-15 12:19:03 +04:00
|
|
|
log $ TerminatingOldProcess appname
|
2013-01-28 11:09:02 +04:00
|
|
|
case mprocPortOld of
|
|
|
|
Nothing -> return ()
|
|
|
|
Just (processOld, _) -> Keter.Process.terminate processOld
|
2012-05-11 08:38:05 +04:00
|
|
|
threadDelay $ 60 * 1000 * 1000
|
2012-05-15 12:19:03 +04:00
|
|
|
log $ RemovingOldFolder dirOld
|
|
|
|
res <- liftIO $ removeTree dirOld
|
|
|
|
case res of
|
2012-05-17 10:32:11 +04:00
|
|
|
Left e -> $logEx e
|
2012-05-15 12:19:03 +04:00
|
|
|
Right () -> return ()
|
2012-05-14 12:03:57 +04:00
|
|
|
|
2012-05-15 12:19:03 +04:00
|
|
|
testApp :: Port -> KIO Bool
|
2012-05-11 08:38:05 +04:00
|
|
|
testApp port = do
|
|
|
|
res <- timeout (90 * 1000 * 1000) testApp'
|
|
|
|
return $ fromMaybe False res
|
|
|
|
where
|
|
|
|
testApp' = do
|
|
|
|
threadDelay $ 2 * 1000 * 1000
|
2012-05-15 12:19:03 +04:00
|
|
|
eres <- liftIO $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port
|
2012-05-11 08:38:05 +04:00
|
|
|
case eres of
|
2012-05-15 12:19:03 +04:00
|
|
|
Left _ -> testApp'
|
2012-05-11 08:38:05 +04:00
|
|
|
Right handle -> do
|
2012-05-15 12:19:03 +04:00
|
|
|
res <- liftIO $ hClose handle
|
|
|
|
case res of
|
2012-05-17 10:32:11 +04:00
|
|
|
Left e -> $logEx e
|
2012-05-15 12:19:03 +04:00
|
|
|
Right () -> return ()
|
2012-05-11 08:38:05 +04:00
|
|
|
return True
|
|
|
|
|
2012-05-15 12:19:03 +04:00
|
|
|
reload :: App -> KIO ()
|
2012-05-11 08:38:05 +04:00
|
|
|
reload (App f) = f Reload
|
|
|
|
|
2012-05-15 12:19:03 +04:00
|
|
|
terminate :: App -> KIO ()
|
2012-05-11 08:38:05 +04:00
|
|
|
terminate (App f) = f Terminate
|
2013-07-10 14:26:37 +04:00
|
|
|
|
|
|
|
pluginsGetEnv :: Plugins -> Appname -> Object -> KIO [(Text, Text)]
|
|
|
|
pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps
|