keter/Keter/App.hs

276 lines
11 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
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)
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)
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
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))
-> 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-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
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
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
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