Keter.App

.gitignore

@@ -4,3 +4,9 @@ dist/
 process.txt
 process2.txt
 postgres.yaml
+*.o
+*.hi
+temp/
+*.keter
+test/app
+incoming/foo/hello

Keter/App.hs

@@ -0,0 +1,171 @@
+{-# 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 Codec.Archive.Tar as Tar
+import qualified Data.ByteString.Lazy as L
+import Codec.Compression.GZip (decompress)
+import qualified System.FilePath as F
+import Data.Text (pack)
+import Data.Yaml
+import Control.Applicative ((<$>), (<*>))
+import qualified Data.IORef as I
+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)
+import System.IO (hClose)
+import System.Directory (removeDirectoryRecursive)
+import Control.Monad (when)
+
+data Config = Config
+    { configExec :: FilePath
+    , configArgs :: [String]
+    , configHost :: String
+    }
+
+instance FromJSON Config where
+    parseJSON (Object o) = Config
+        <$> o .: "exec"
+        <*> o .:? "args" .!= []
+        <*> o .: "host"
+    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
+             -> FilePath
+             -> Appname
+             -> IO (Maybe (FilePath, Config))
+unpackBundle tf bundle appname = tryM $ do
+    lbs <- L.readFile bundle
+    dir <- getFolder tf appname
+    putStrLn $ "Unpacking bundle to: " ++ dir
+    let rest = do
+            Tar.unpack dir $ Tar.read $ decompress lbs
+            let configFP = dir F.</> "config" F.</> "keter.yaml"
+            Just config <- decodeFile configFP
+            return (dir, config)
+    rest `onException` removeDirectoryRecursive dir
+
+start :: TempFolder
+      -> Nginx
+      -> FilePath -- ^ app bundle
+      -> IO () -- ^ action to perform to remove this App from list of actives
+      -> IO (App, IO ())
+start tf nginx bundle removeFromList = do
+    chan <- C.newChan
+    return (App $ C.writeChan chan, rest chan)
+  where
+    appname = pack $ F.takeBaseName bundle
+    void f = f >> return ()
+
+    runApp port dir config = do
+        setFileMode (dir F.</> "config" F.</> configExec config) ownerExecuteMode
+        run
+            ("config" F.</> configExec config)
+            dir
+            (configArgs config)
+            [ ("PORT", show port)
+            ]
+
+    rest chan = void $ forkIO $ do
+        mres <- unpackBundle tf bundle appname
+        case mres of
+            Nothing -> removeFromList
+            Just (dir, config) -> do
+                port <- getPort nginx
+                process <- runApp port dir config
+                b <- testApp port
+                if b
+                    then do
+                        addEntry nginx (configHost config) $ AppEntry port
+                        loop chan dir process port config
+                    else do
+                        removeFromList
+                        releasePort nginx port
+                        Keter.Process.terminate process
+
+    loop chan dirOld processOld portOld configOld = do
+        command <- C.readChan chan
+        case command of
+            Terminate -> do
+                removeFromList
+                removeEntry nginx $ configHost configOld
+                terminateOld
+            Reload -> do
+                mres <- unpackBundle tf bundle appname
+                case mres of
+                    Nothing -> do
+                        putStrLn $ "Invalid bundle: " ++ bundle
+                        loop chan dirOld processOld portOld configOld
+                    Just (dir, config) -> do
+                        port <- getPort nginx
+                        process <- runApp port dir config
+                        b <- testApp port
+                        if b
+                            then do
+                                addEntry nginx (configHost config) $ AppEntry port
+                                when (configHost config /= configHost configOld) $
+                                    removeEntry nginx $ configHost configOld
+                                terminateOld
+                                loop chan dir process port config
+                            else do
+                                releasePort nginx port
+                                Keter.Process.terminate process
+                                putStrLn $ "Processing didn't start correctly: " ++ bundle
+                                loop chan dirOld processOld portOld configOld
+      where
+        terminateOld = void $ forkIO $ do
+            threadDelay $ 20 * 1000 * 1000
+            putStrLn $ "Terminating old process for: " ++ show appname
+            Keter.Process.terminate processOld
+            threadDelay $ 60 * 1000 * 1000
+            putStrLn $ "Removing folder: " ++ dirOld
+            removeDirectoryRecursive dirOld
+
+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

Keter/Nginx.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Keter.Nginx
     ( -- * Types
       Port
@@ -36,6 +37,8 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromString, fromShow)
 import Data.Monoid (Monoid, mappend, mconcat)
 import Data.ByteString.Char8 ()
 import System.Directory (renameFile)
+import qualified Network
+import Control.Exception (SomeException, try)
 
 (<>) :: Monoid m => m -> m -> m
 (<>) = mappend
@@ -90,15 +93,24 @@ start Settings{..} = do
         command <- lift $ C.readChan chan
         case command of
             GetPort f -> do
-                ns <- S.get
-                let (port, ns') =
+                ns0 <- S.get
+                let loop ns =
                         case nsAvail ns of
-                            p:ps -> (p, ns { nsAvail = ps })
+                            p:ps -> do
+                                res <- try $ Network.listenOn $ Network.PortNumber $ fromIntegral p
+                                case res of
+                                    Left (_ :: SomeException) -> do
+                                        putStrLn $ "Removing port from use: " ++ show p
+                                        loop ns { nsAvail = ps }
+                                    Right socket -> do
+                                        Network.sClose socket
+                                        return (p, ns { nsAvail = ps })
                             [] ->
                                 case reverse $ nsRecycled ns of
-                                    [] -> (error "No ports available", ns)
-                                    p:ps -> (p, ns { nsAvail = ps, nsRecycled = [] })
-                S.put ns'
+                                    [] -> return (error "No ports available", ns)
+                                    ps -> loop ns { nsAvail = ps, nsRecycled = [] }
+                (port, ns) <- lift $ loop ns0
+                S.put ns
                 lift $ f port
             ReleasePort p ->
                 S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns }

Keter/Process.hs

@@ -24,6 +24,7 @@ run exec dir args env = do
                     NoRestart -> return (NoRestart, return ())
                     _ -> do
                         (_, _, _, ph) <- SP.createProcess cp
+                        putStrLn "Process created"
                         return (Running ph, SP.waitForProcess ph >> loop)
             next
     _ <- forkIO loop

incoming/foo/bundle.sh

@@ -0,0 +1,4 @@
+#!/bin/bash -ex
+
+ghc --make hello.hs
+tar czfv ../foo.keter *

incoming/foo/config/keter.yaml

@@ -0,0 +1,4 @@
+exec: ../hello
+args:
+    - Hello World 1
+host: tealc-mint

incoming/foo/hello.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+import System.Environment
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.HTTP.Types
+
+main :: IO ()
+main = do
+    [msg] <- getArgs
+    portS <- getEnv "PORT"
+    let port = read portS
+    run port $ const $ return $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack msg

keter.cabal

@@ -21,12 +21,16 @@ Library
                      , process
                      , random
                      , data-default
+                     , filepath
+                     , zlib
+                     , tar
                      , blaze-builder             >= 0.3           && < 0.4
                      , yaml                      >= 0.7           && < 0.8
   Exposed-Modules:     Keter.Nginx
                        Keter.Process
                        Keter.Postgres
                        Keter.TempFolder
+                       Keter.App
   ghc-options:         -Wall -Werror
 
 Executable keter

test/app.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Keter.TempFolder
+import Keter.App
+import qualified Keter.Nginx as N
+import Data.Default
+import Control.Concurrent
+import System.Directory (copyFile)
+
+main :: IO ()
+main = do
+    tf <- setup "temp"
+    nginx <- N.start def
+    copyFile "incoming/foo1.keter" "incoming/foo.keter"
+    (app, toRun) <- start tf nginx "incoming/foo.keter" $ putStrLn "It's dead Jim"
+    toRun
+    threadDelay $ 2 * 1000 * 1000
+    copyFile "incoming/foo2.keter" "incoming/foo.keter"
+    reload app
+    threadDelay $ 2 * 1000 * 1000
+    putStrLn "Terminating..."
+    terminate app
+    threadDelay $ 120 * 1000 * 1000