keter/Keter/App.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Keter.App
    ( App
    , start
    , reload
    , Keter.App.terminate
    ) where

import Keter.TempFolder
import Keter.Postgres
import Keter.Process
import Keter.Nginx hiding (start)
import qualified Keter.Prelude
import qualified Codec.Archive.Tar as Tar
import Codec.Compression.GZip (decompress)
import qualified Filesystem.Path.CurrentOS as F
import Data.Yaml
import Control.Applicative ((<$>), (<*>))
import System.PosixCompat.Files
import qualified Control.Concurrent.Chan as C
import Control.Concurrent (forkIO, threadDelay)
import System.Timeout (timeout)
import qualified Network
import Data.Maybe (fromMaybe)
import Control.Exception (try, SomeException, onException, throwIO)
import System.IO (hClose)
import System.Directory (removeDirectoryRecursive)
import Control.Monad (when)
import Data.Text (Text, pack)

data Config = Config
    { configExec :: F.FilePath
    , configArgs :: [Text]
    , configHost :: String
    , configPostgres :: Bool
    }

instance FromJSON Config where
    parseJSON (Object o) = Config
        <$> (F.fromText <$> o .: "exec")
        <*> o .:? "args" .!= []
        <*> o .: "host"
        <*> o .:? "postgres" .!= False
    parseJSON _ = fail "Wanted an object"

data Command = Reload | Terminate
newtype App = App (Command -> IO ())

tryM :: IO a -> IO (Maybe a)
tryM f = do
    res <- try f
    case res of
        Left (e :: SomeException) -> do
            putStrLn $ "Exception received: " ++ show e
            return Nothing
        Right x -> return $ Just x

unpackBundle :: TempFolder
             -> F.FilePath
             -> Appname
             -> IO (Maybe (FilePath, Config))
unpackBundle tf bundle appname = tryM $ do
    elbs <- runKIO $ Keter.Prelude.readFileLBS bundle
    lbs <- either throwIO return elbs
    edir <- runKIO $ getFolder tf appname
    dir <- either throwIO return edir
    putStrLn $ "Unpacking bundle to: " ++ show dir
    let rest = do
            Tar.unpack (F.encodeString dir) $ Tar.read $ decompress lbs
            let configFP = dir F.</> "config" F.</> "keter.yaml"
            Just config <- decodeFile $ F.encodeString configFP
            return (F.encodeString dir, config)
    rest `onException` Keter.Prelude.removeTree dir

start :: TempFolder
      -> Nginx
      -> Postgres
      -> Appname
      -> F.FilePath -- ^ app bundle
      -> IO () -- ^ action to perform to remove this App from list of actives
      -> IO (App, IO ())
start tf nginx postgres appname bundle removeFromList = do
    chan <- C.newChan
    return (App $ C.writeChan chan, rest chan)
  where
    void f = f >> return ()

    runApp port dir config = do
        setFileMode (F.encodeString $ F.decodeString dir F.</> "config" F.</> configExec config) ownerExecuteMode
        otherEnv <- do
            mdbi <-
                if configPostgres config
                    then do
                        edbi <- Keter.Prelude.runKIO print $ getInfo postgres appname
                        case edbi of
                            Left e -> do
                                Keter.Prelude.runKIO print $ Keter.Prelude.log $ Keter.Prelude.ExceptionThrown 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 -> []
        runKIO $ run
            ("config" F.</> configExec config)
            (F.decodeString dir)
            (configArgs config)
            $ ("PORT", pack $ show port)
            : ("APPROOT", pack $ "http://" ++ configHost config)
            : otherEnv

    rest chan = void $ forkIO $ do
        mres <- unpackBundle tf bundle appname
        case mres of
            Nothing -> removeFromList
            Just (dir, config) -> do
                eport <- runKIO $ getPort nginx
                case eport of
                    Left e -> do
                        runKIO $ Keter.Prelude.log $ Keter.Prelude.ExceptionThrown e
                        removeFromList
                    Right port -> do
                        process <- runApp port dir config
                        b <- testApp port
                        if b
                            then do
                                runKIO $ addEntry nginx (pack $ configHost config) $ AppEntry port
                                loop chan dir process port config
                            else do
                                removeFromList
                                runKIO $ releasePort nginx port
                                runKIO $ Keter.Process.terminate process

    loop chan dirOld processOld portOld configOld = do
        command <- C.readChan chan
        case command of
            Terminate -> do
                removeFromList
                runKIO $ removeEntry nginx $ pack $ configHost configOld
                putStrLn $ "Received terminate signal for app: " ++ show appname
                terminateOld
            Reload -> do
                mres <- unpackBundle tf bundle appname
                case mres of
                    Nothing -> do
                        runKIO $ Keter.Prelude.log $ Keter.Prelude.InvalidBundle bundle
                        loop chan dirOld processOld portOld configOld
                    Just (dir, config) -> do
                        eport <- runKIO $ getPort nginx
                        case eport of
                            Left e -> runKIO $ Keter.Prelude.log $ Keter.Prelude.ExceptionThrown e
                            Right port -> do
                                process <- runApp port dir config
                                b <- testApp port
                                if b
                                    then do
                                        runKIO $ addEntry nginx (pack $ configHost config) $ AppEntry port
                                        when (configHost config /= configHost configOld) $
                                            runKIO $ removeEntry nginx $ pack $ configHost configOld
                                        putStrLn $ "Finished reloading: " ++ show appname
                                        terminateOld
                                        loop chan dir process port config
                                    else do
                                        runKIO $ do
                                            releasePort nginx port
                                            Keter.Process.terminate process
                                            Keter.Prelude.log $ Keter.Prelude.ProcessDidNotStart bundle
                                        loop chan dirOld processOld portOld configOld
      where
        terminateOld = void $ forkIO $ do
            threadDelay $ 20 * 1000 * 1000
            putStrLn $ "Terminating old process for: " ++ show appname
            runKIO $ Keter.Process.terminate processOld
            threadDelay $ 60 * 1000 * 1000
            putStrLn $ "Removing folder: " ++ dirOld
            removeDirectoryRecursive dirOld

runKIO :: Keter.Prelude.KIO a -> IO a -- FIXME remove this
runKIO = Keter.Prelude.runKIO print

testApp :: Port -> IO Bool
testApp port = do
    putStrLn $ "Testing app on port: " ++ show port
    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 (e :: SomeException) -> do
                putStrLn $ "Connection failed: " ++ show e
                testApp'
            Right handle -> do
                putStrLn $ "App is running on port: " ++ show port
                hClose handle
                return True

reload :: App -> IO ()
reload (App f) = f Reload

terminate :: App -> IO ()
terminate (App f) = f Terminate