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
|
2013-07-14 14:02:18 +04:00
|
|
|
import qualified Filesystem as F
|
2012-05-11 08:38:05 +04:00
|
|
|
import Data.Yaml
|
2013-07-14 16:28:48 +04:00
|
|
|
import Control.Applicative ((<$>))
|
2012-05-11 08:38:05 +04:00
|
|
|
import qualified Network
|
2013-07-14 14:02:18 +04:00
|
|
|
import Data.Maybe (fromMaybe)
|
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 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)
|
2013-07-14 14:02:18 +04:00
|
|
|
import Data.Yaml.FilePath
|
2012-10-21 09:07:26 +04:00
|
|
|
|
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
|
2013-07-14 16:28:48 +04:00
|
|
|
-> KIO (Either SomeException (FilePath, BundleConfig))
|
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"
|
2013-07-14 14:02:18 +04:00
|
|
|
mconfig <- decodeFileRelative configFP
|
2013-07-10 15:09:14 +04:00
|
|
|
config <-
|
|
|
|
case mconfig of
|
2013-07-14 14:02:18 +04:00
|
|
|
Right config -> return config
|
|
|
|
Left e -> throwIO $ InvalidConfigFile e
|
|
|
|
config' <-
|
2013-07-14 16:28:48 +04:00
|
|
|
case bconfigApp config of
|
2013-07-14 14:02:18 +04:00
|
|
|
Nothing -> return config
|
|
|
|
Just app -> do
|
2013-07-14 16:28:48 +04:00
|
|
|
abs <- F.canonicalizePath $ aconfigExec app
|
2013-07-14 14:02:18 +04:00
|
|
|
return config
|
2013-07-14 16:28:48 +04:00
|
|
|
{ bconfigApp = Just app
|
|
|
|
{ aconfigExec = abs
|
2013-07-14 14:02:18 +04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
return (dir, config')
|
2012-10-12 14:59:46 +04:00
|
|
|
|
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-14 16:28:48 +04:00
|
|
|
otherEnv <- pluginsGetEnv plugins appname (aconfigRaw config)
|
2012-05-17 10:32:11 +04:00
|
|
|
let env = ("PORT", show port)
|
2013-07-14 16:28:48 +04:00
|
|
|
: ("APPROOT", (if aconfigSsl config then "https://" else "http://") ++ aconfigHost 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)
|
2013-07-14 16:28:48 +04:00
|
|
|
(aconfigExec config)
|
2012-05-15 12:19:03 +04:00
|
|
|
dir
|
2013-07-14 16:28:48 +04:00
|
|
|
(aconfigArgs 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
|
2013-07-14 16:28:48 +04:00
|
|
|
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
|
2013-01-28 11:09:02 +04:00
|
|
|
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
|
2013-07-14 16:28:48 +04:00
|
|
|
addEntry portman (aconfigHost appconfig) $ PEPort port
|
|
|
|
mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig
|
2013-01-28 11:09:02 +04:00
|
|
|
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-07-14 16:28:48 +04:00
|
|
|
case bconfigApp configOld of
|
2013-01-28 11:09:02 +04:00
|
|
|
Nothing -> return ()
|
|
|
|
Just appconfig -> do
|
2013-07-14 16:28:48 +04:00
|
|
|
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
|
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
|
2013-07-14 16:28:48 +04:00
|
|
|
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
|
2013-01-28 11:09:02 +04:00
|
|
|
Nothing -> do
|
|
|
|
common
|
|
|
|
loop chan dir config Nothing
|
|
|
|
Just appconfig -> do
|
|
|
|
process <- runApp port dir appconfig
|
|
|
|
b <- testApp port
|
|
|
|
if b
|
|
|
|
then do
|
2013-07-14 16:28:48 +04:00
|
|
|
addEntry portman (aconfigHost appconfig) $ PEPort port
|
|
|
|
mapM_ (flip (addEntry portman) $ PEPort port) $ Set.toList $ aconfigExtraHosts appconfig
|
2013-01-28 11:09:02 +04:00
|
|
|
common
|
2013-07-14 16:28:48 +04:00
|
|
|
case bconfigApp configOld of
|
|
|
|
Just appconfigOld | aconfigHost appconfig /= aconfigHost appconfigOld ->
|
|
|
|
removeEntry portman $ aconfigHost appconfigOld
|
2013-01-28 11:09:02 +04:00
|
|
|
_ -> 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
|