keter/Keter/App.hs

215 lines
9.2 KiB
Haskell
Raw Normal View History

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
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)
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)
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
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
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))
-> ProcessTracker
-> PortManager
2013-07-10 14:26:37 +04:00
-> Plugins
-> 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
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
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
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